perm filename PUB.SAI[OK,TES] blob
sn#119646 filedate 1974-09-06 generic text, type T, neo UTF8
00100 BEGIN "PUB" COMMENT Begun April 23, 1971, Completed Asymptotically ;
00200
00300
00400 COMMENT FILES TO COMPILE:
00500
00600 PUB.SAI (This one)
00700 FILLER.SAI (The Line Filler)
00800 PARSER.SAI (The Command Scanner/Parser)
00900
01000 REQUIRED FILES:
01100 By all: PUBDFS.SAI PUBINR.SAI
01200 By FILLER and PARSER only:
01300 PUBMAI.SAI PUBPRO.SAI
01400
01500 NEEDED TO RUN PUB:
01600 PUB.DMP (From this compilation)
01700 PUB2.DMP (From compiling PUB2.SAI)
01800 PUBSTD.DFS (Standard Macro File)
01900 SYS:TXTF80.DMP (For microfilm output only)
02000
02100 FORMS FOR THE DEBUG SWITCH (BREAKPOINTS A LINE):
02200 /Z04100/2/ or (Z04100/2/) Manuscript P. 2 Line 04100
02300 /ZPUB33/1/ or (ZPUB33/1/) PUBSTD.DFS P. 1 Line 33
02400
02500 DOCUMENTATION FILES:
02600 PUB.DOC[S,DOC]
02700 PUBMAC.DOC[S,DOC]
02800
02900 DO FILE FOR GENERATING SYSTEM (DO NIT):
03000 LOAD PUB.SAI(5000S),PARSER.SAI(5000S),FILLER.SAI(5000SR)↔SAVE PUB↔DO NIT(2)↔|
03100 LOAD PUB2.SAI(5000SR)↔SAVE PUB2↔
03200
03300 If the user is logged in as xx2,TES then PUB expects
03400 PUB2.DMP and PUBSTD.DFS to be in the same directory.
03500 Otherwise, it expects them to be in 1,3
03600 ;
03700
03800 DEFINE TERNAL = "INTERNAL", PRELOAD = "PRELOAD!WITH" ;
03900 REQUIRE "PUBDFS" SOURCE!FILE ;
04000 comment, The DEFINEs, constant-bound arrays, and global variables ;
04100
04200 TES LAST UPDATED 6/11/74: ;
04300 IFC TENEX THENC
04400 REQUIRE 30000 STRING!SPACE ;
04500 REQUIRE 2500 SYSTEM!PDL ;
04600 REQUIRE 2500 STRING!PDL ;
04700 ELSEC
04800 IFC VERSION=ITSVER
04810 THENC REQUIRE 10000 STRING!SPACE ;
04820 ELSEC REQUIRE 4000 STRING!SPACE ;
04830 ENDC
04900 REQUIRE IFC VERSION=CMUVER THENC 650 ELSEC 400 ENDC SYSTEM!PDL ;
05000 REQUIRE 200 STRING!PDL ;
05100 ENDC
00100 EXTERNAL INTEGER SIMPLE PROCEDURE XLENGTH(STRING S);
00200 EXTERNAL PROCEDURE READFONT(INTEGER WHICH; STRING FILENAME, XFILENAME);
00250 EXTERNAL INTEGER !ERRP! ; TES 8/19/74 INTERCEPT SAIL ERRORS ;
00300
00400 COMMENT The following INTERNAL SIMPLE PROCEDUREs are EXTERNAL in PUBMAI.SAI ;
00500
00600 INTERNAL STRING SIMPLE PROCEDURE SPS(INTEGER N) ; IF N≤10 THEN RETURN(SPSARR[N MAX 0]) ELSE
00700 BEGIN
00800 STRING S ; INTEGER I ;
00900 S ← " " ;
01000 FOR I ← 20 STEP 10 UNTIL N DO S ← S & " " ;
01100 RETURN(S & SPSARR[N-I+10]) ;
01200 END ;
01300
01400 COMMENT DYNAMIC ARRAY MANIPULATION PACKAGE (ARRSER.SAI[1,DCS]) ;
01500
01600 EXTERNAL INTEGER GOGTAB ;
01700
01800 DSCR PTR←WHATIS(ARRAY)
01900 PAR ARRAY OF ANY ARITHMETIC OR SET BREED
02000 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
02100 ;
02200
02300 INTERNAL INTEGER SIMPLE PROCEDURE WHATIS(INTEGER ARRAY A);
02400 START!CODE "WHATIS"
02500 MOVE 1,A;
02600 END "WHATIS";
02700
02800
02900
03000 DSCR PTR←SWHATIS(ARRAY)
03100 PAR STRING ARRAY
03200 RES PTR←DSCRPTR, SAIL CAN THEN TREAT IT AS AN INTEGER
03300 ;
03400
03500 INTERNAL INTEGER SIMPLE PROCEDURE SWHATIS(STRING ARRAY A);
03600 START!CODE "SWHATIS"
03700 MOVE 1,A;
03800 END "SWHATIS";
03900
04000
04100 DSCR GOAWAY(PTR)
04200 PAR PTR IS ARRAY DESCRIPTOR
04300 DES ARRAY IS RLEASD
04400 ;
04500
04600 INTERNAL SIMPLE PROCEDURE GOAWAY(INTEGER I) ;
04700 BEGIN COMMENT Be SURE Left Half is -1 for String Arrays! ;
04800 START!CODE MOVE '15, GOGTAB END ;
04900 IF LH(I) THEN
05000 START!CODE "SARID"
05100 HRRZ 1, I ; MOVE 1, 0(1) ; COMMENT [PREV,,NEXT] ;
05200 HLRZ 2, 1 ; HRRM 1, 0(2) ; COMMENT PREV ← [...,,NEXT] ;
05300 HRRZ 2, 1 ; SKIPE 2 ; HLLM 1, 0(2) ; COMMENT NEXT ← [PREV,,...] ;
05400 END "SARID" ;
05500 ARYEL(I) ;
05600 END "GOAWAY" ;
00100 INTERNAL INTEGER SIMPLE PROCEDURE BIGGER(INTEGER PTR,HM);
00200 BEGIN "BIGGER"
00300 INTEGER PT;
00400 START!CODE "BIG1"
00500 MOVE '15, GOGTAB ; COMMENT BECAUSE OF LRCOP BUG ;
00600 MOVE TEMPO,HM;
00700 MOVE LPSA,PTR;
00800 ADDM TEMPO,-3(LPSA);
00900 ADDM TEMPO,-1(LPSA);
01000 MOVNS TEMPO;
01100 ADDM TEMPO,-6(LPSA);
01200 END "BIG1";
01300 PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
01400 START!CODE "BIG2"
01500 MOVE TEMPO,HM;
01600 MOVE LPSA,PTR;
01700 ADDM TEMPO,-6(LPSA);
01800 END "BIG2";
01900 GOAWAY(PTR); "DELETE THE OLD COPY"
02000 RETURN(PT); "HERE IS THE NEW COPY";
02100 END "BIGGER";
02200
02300
02400 DSCR PTR1←SBIGGER(PTR,HOWMUCH)
02500 PAR PTR IS ARRAY (1-D STRING) DESCRIPTOR
02600 HOWMUCH NUMBER OF ELEMENTS INCREASE DESIRED
02700 RES PTR1 IS DESCRIPTOR OF BIGGER ARRAY
02800 THE OLD DATA IS COPIED, THE OLD ARRAY HAS DISAPPEARED
02900 ;
03000
03100 INTERNAL INTEGER SIMPLE PROCEDURE SBIGGER(INTEGER PTR,HM);
03200 BEGIN "SBIGGER"
03300 INTEGER PT;
03400 START!CODE "SBIG1"
03500 MOVE '15, GOGTAB ;
03600 MOVE TEMPO,HM;
03700 MOVE LPSA,PTR;
03800 ADDM TEMPO,-4(LPSA);
03900 LSH TEMPO,1;
04000 ADDM TEMPO,-2(LPSA);
04100 MOVNS TEMPO;
04200 ADDM TEMPO,-7(LPSA);
04300 END "SBIG1";
04400 PT←LRCOP(PTR); "DO THE COPY AND INCREASE"
04500 START!CODE "SBIG2"
04600 MOVE TEMPO,HM;
04700 MOVE LPSA,PTR;
04800 LSH TEMPO,1;
04900 ADDM TEMPO,-7(LPSA);
05000 END "SBIG2";
05100 GOAWAY(PTR); "DELETE THE OLD COPY"
05200 RETURN(PT); "HERE IS THE NEW COPY";
05300 END "SBIGGER";
00100 COMMENT Declares
00200 IDA ← [S]CREATE(LOWBND, HIGHBND) to create a (string or) integer array
00300 MAKEBE(IDA,ALIAS) to give its descriptor to array ALIAS
00400 IDA ← [S]WHATIS(ALIAS) to take it back
00500 GOAWAY(IDA) to destroctulate it
00600 IDA ← [S]BIGGER(IDA,XTRA) to add XTRA words to its length ;
00700
00800
00900 INTEGER SIMPLE PROCEDURE SCREATE(INTEGER LB1, UB1) ;
01000 BEGIN "SCREATE"
01100 INTEGER IDA ;
01200 START!CODE MOVE '15, GOGTAB END ;
01300 IDA ← LRMAK(LB1, UB1, -1 LSH 18 + 1) ;
01400 RETURN(IDA) ;
01500 END "SCREATE" ;
01600
01700 INTERNAL INTEGER SIMPLE PROCEDURE CREATE2(INTEGER LB1, UB1, LB2, UB2) ;
01800 BEGIN "CREATE2"
01900 EXTERNAL INTEGER SIMPLE PROCEDURE LRMAK(INTEGER LB1, UB1, LB2, UB2, D) ;
02000 START!CODE MOVE '15, GOGTAB END ; COMMENT LRCOP BUG ;
02100 RETURN(LRMAK(LB1, UB1, LB2, UB2, 2)) ;
02200 END "CREATE2" ;
02300
02400 IFC VERSION=CMUVER OR VERSION=SAILVER THENC
02500 RKJ: 6-25-74 Do your own USERERR;
02600
02700 PROCEDURE CALLEDITOR(STRING EDNAME);
02800 BEGIN TES 8/20/74 ADDED SAIL CASES ;
02900 SAFE INTEGER ARRAY B[0:5];
03000 STRING FILE;
03100 INTEGER LINE,PAGE,F,E,P;
03200 FILE←INCHWL;
03300 IF FULSTR(FILE)
03400 THEN LINE←PAGE←0
03500 ELSE
03600 BEGIN "DEFAULTFILE"
03700 FILE←THISFILE;
03800 LINE←CVASC(SRCLINE) LOR 1;
03900 PAGE←CVD(SRCPAGE);
04000 END "DEFAULTFILE";
04100 B[0]←CVSIX("SYS");
04200 B[1]←CVSIX(EDNAME);
04300 B[2]←B[3]←B[4]←B[5]←0;
04400 F←CVFIL(FILE,E,P);
04500 START!CODE "RUNEDITOR"
04600 MOVE '14,F; MOVE '13,E; MOVE '11,P; MOVE '16,PAGE; MOVE '15,LINE;
04700 MOVE 1,B; HRLI 1,1;
04800 CALLI 1,'35;
04900 JRST 4,0;
05000 END "RUNEDITOR";
05100 END "CALLEDITOR";
05200 ELSEC DEFINE CALLEDITOR(DUMMY) = "DONE" ; TES 8/20/74 ;
05300 ENDC
05400
05500 INTERNAL STRING SIMPLE PROCEDURE ERRLINE ;
05600 RETURN(IF EQU(MAINFILE, THISFILE) THEN SRCLINE
05700 ELSE THISFILE&SP&SRCLINE) ;
05800
05900 SIMPLE INTEGER PROCEDURE NERROR(INTEGER LOC; STRING MESG, RSP) ;
06000 RETURN(RSP + 3 LSH 18) ; TES 8/20/74 CALLED BY ERROR ;
06100
06200 STRING SIMPLE PROCEDURE WARN(STRING SHORT!VERSION, LONG!VERSION) ;
06300 USERERR(0,1,LONG!VERSION) ; TES 8/20/74 USED BEFORE INITIALLIZATION IS COMPLETE ;
06400
06500 IFC TENEX THENC TES 10/25/73 ;
06600 INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN; STRING NAME, EXT; INTEGER JUNK; STRING PPN) ;
06700 BEGIN COMMENT RETURNS TRUE IF SUCCESSFUL ;
06800 BOOLEAN FLAG ;
06900 LOOKUP(CHAN, PPN & NAME & EXT, FLAG) ;
07000 RETURN(NOT FLAG) ;
07100 END ;
07200
07300 STRING PROCEDURE SCANTO(STRING BRKS; REFERENCE STRING SCANNEE; BOOLEAN INCLUDE) ;
07400 BEGIN
07500 INTEGER DUMMY ;
07600 SETBREAK(LOCAL!TABLE, BRKS, NULL, IF INCLUDE THEN "IA" ELSE "IR") ;
07700 RETURN(SCAN(SCANNEE, LOCAL!TABLE, DUMMY)) ;
07800 END ;
07900
08000 STRING SIMPLE PROCEDURE CVFIL(STRING FILENAME; REFERENCE STRING EXT, PPN) ;
08100 BEGIN
08200 STRING NAME ;
08300 PPN ← IF FILENAME[1 FOR 1] = "<" THEN SCANTO(">", FILENAME, TRUE) ELSE NULL ;
08400 NAME ← SCANTO(".;", FILENAME, FALSE) ;
08500 EXT ← IF FILENAME[1 FOR 1] = "." THEN SCANTO(";", FILENAME, FALSE) ELSE NULL ;
08600 RETURN(NAME) ;
08700 END ;
08800 ELSEC
08900 INTERNAL BOOLEAN SIMPLE PROCEDURE XLOOKUP(INTEGER CHAN, NAME, EXT, JUNK, PPN) ;
09000 START!CODE "XLOOKUP"
09100 MOVE 2,CHAN;
09200 LSH 2,23;
09300 IFC VERSION=ITSVER
09400 THENC IOR 2,['027017777774] PJ 5/28/74 ;
09500 ELSEC IOR 2,['076017777774] ENDC ; COMMENT LOOKUP 0,-4(17) ;
09600 SETO 1,0; COMMENT TRUE ;
09700 XCT 0,2;
09800 SETZ 1,0; COMMENT FALSE ;
09900 END "XLOOKUP";
10000 ENDC
00100 BOOLEAN GENREXT ;
00200
00300 IFC TENEX THENC
00400
00500 DEFINE SUBCMDS="10" ;
00600 DEFINE DCASE="1", XCASE="2", TCASE="3", PCASE="4", SCASE="5",
00700 YCASE="6", NCASE="7", ACASE="8", BCASE="9", HCASE="10",
00800 QUESTCASE="11", CRCASE="12" ; COMMENT ALWAYS LAST TWO ;
00900 PRELOAD!WITH "ERROR", "DOCUMENT: ", "XGP", "TTY", "PRINT DEBUG INFO", "SPREAD=",
01000 "YES", "NO", "ASK", "BIG", "HUGE" ;
01100 STRING ARRAY COMPLETION[0:SUBCMDS] ;
01200 PRELOAD!WITH "ERROR", "(OUTPUT FILE NAME)", "PRINT DEVICE", "PRINT DEVICE (DEFAULT)",
01300 "(LINE NUMBERS AND ERRORS) IN MARGIN OF DOCUMENT",
01400 "1 TO 9 (DEFAULT IS 1=SINGLE SPACE)",
01500 "DO DELETE INTERMEDIATE FILES (DEFAULT)",
01600 "DONT DELETE INTERMEDIATE FILES",
01700 "TO DELETE INTERMEDIATE FILES",
01800 "SYMBOL TABLE", "SYMBOL TABLE" ;
01900 STRING ARRAY EXPLANATION[0:SUBCMDS] ;
02000
02100 SIMPLE BOOLEAN PROCEDURE SUBCOMMAND(INTEGER NUMBER) ;
02200 BEGIN
02300 INTEGER N ;
02400 OUTSTR(COMPLETION[NUMBER][2 TO ∞]) ;
02500 N ← INCHRW ;
02600 IF N="?" OR N=ALTMODE THEN
02700 BEGIN
02800 OUTSTR(SP & EXPLANATION[NUMBER]) ;
02900 N ← INCHRW ;
03000 END ;
03100 IF N=CR OR N=EOL THEN RETURN(TRUE) ;
03200 IF N=ALTMODE OR N=SP THEN
03300 BEGIN OUTSTR(CRLF) ; RETURN(TRUE) ; END ;
03400 OUTSTR("XXX"&CRLF) ; RETURN(FALSE) ;
03500 END "SUBCOMMAND" ;
03600
03700 SIMPLE INTEGER PROCEDURE INDIGIT ;
03800 BEGIN
03900 INTEGER N ;
04000 N ← INCHRW ;
04100 IF N="?" THEN
04200 BEGIN
04300 OUTSTR(EXPLANATION[SCASE]) ;
04400 N ← INCHRW ;
04500 END ;
04600 IF N=ALTMODE THEN BEGIN OUTSTR("1"&CRLF) ; RETURN(1) END ;
04700 IF "1" LEQ N AND N LEQ "9" THEN
04800 BEGIN OUTSTR(CRLF) ; RETURN(N-"0") END ;
04900 OUTSTR("XXX"&CRLF) ; RETURN(0) ;
05000 END "INDIGIT" ;
05100
05200 SIMPLE PROCEDURE TENEXSTART ;
05300 BEGIN
05400 INTEGER N ; BOOLEAN DUN ;
05500 PRELOAD!WITH
05600 [13]0, CRCASE, [17]0, CRCASE,
05700 [31]0, QUESTCASE,
05800 0, ACASE, BCASE, 0, DCASE, 0, 0, 0,
05900 HCASE, 0, 0, 0, 0, 0, NCASE, 0,
06000 PCASE, 0, 0, SCASE, TCASE, 0, 0, 0,
06100 XCASE, YCASE, 0, [5]0,
06200 0, ACASE, BCASE, 0, DCASE, 0, 0, 0,
06300 HCASE, 0, 0, 0, 0, 0, NCASE, 0,
06400 PCASE, 0, 0, SCASE, TCASE, 0, 0, 0,
06500 XCASE, YCASE, 0, [5]0 ;
06600 OWN INTEGER ARRAY CNVCASE[0:127] ;
06700 OUTFILE ← NULL ;
06800 DO BEGIN "GTINCHAN" TES 6/11/74 ;
06900 OUTSTR("MANUSCRIPT: ") ;
07000 WHILE -1 = (INCHAN ←
07100 GTJFNL(NULL, '162000000000, '100000101,
07200 NULL, NULL, NULL, "PUB", NULL, NULL, NULL)) DO
07300 OUTSTR(" ?" & CRLF & "MANUSCRIPT: ") ;
07400 OPENF(INCHAN, 2) ;
07500 IF !SKIP! THEN
07600 BEGIN
07700 OUTSTR("CAN'T OPEN MANUSCRIPT; IS PROTECTION OK?"&CRLF) ;
07800 RLJFN(INCHAN) ;
07900 END
08000 ELSE DONE ;
08100 END "GTINCHAN"
08200 UNTIL FALSE ;
08300 INFILE ← JFNS(INCHAN, '211110040001) ;
08400 INPPN ← JFNS(INCHAN, '10000000001) ;
08500 IFILENAME ← JFNS(INCHAN, '1000000000) ;
08600 EOF ← 0 ; SETINPUT(INCHAN, 150, BRC, EOF) ;
08700 DUN ← FALSE ;
08800 BKJFN('100) ; COMMENT WAS THE CONFIRM WITH A COMMA? ;
08900 IF CHARIN('100) = "," THEN
09000 BEGIN "SUBCOMMANDS"
09100 OUTSTR(CRLF) ;
09200 DO BEGIN
09300 OUTSTR("@@") ;
09400 CASE CNVCASE[INCHRW] OF
09500 BEGIN
09600 [0] OUTSTR("?"&CRLF) ;
09700 [DCASE] BEGIN
09800 OUTSTR(COMPLETION[DCASE][2 TO ∞]) ;
09900 N ← GTJFNL(NULL, '462000000000,
10000 '100000101, NULL, NULL, IFILENAME,
10100 "DOC", NULL, NULL, NULL) ;
10200 IF N=-1 THEN OUTSTR("XXX"&CRLF)
10300 ELSE BEGIN
10400 OUTFILE ← JFNS(N, 0) ;
10500 RLJFN(N) ; OUTSTR(CRLF) ;
10600 END ;
10700 END ;
10800 [XCASE] IF SUBCOMMAND(XCASE) THEN DEVICE←-XGP ;
10900 [TCASE] IF SUBCOMMAND(TCASE) THEN DEVICE←-TTY ;
11000 [PCASE] IF SUBCOMMAND(PCASE) THEN DEBUG←-1 ;
11100 [SCASE] BEGIN
11200 OUTSTR(COMPLETION[SCASE][2 TO ∞]) ;
11300 IF (N←INDIGIT) THEN PREFMODE←N ;
11400 END ;
11500 [YCASE] IF SUBCOMMAND(YCASE) THEN DELINT←"Y" ;
11600 [NCASE] IF SUBCOMMAND(NCASE) THEN DELINT←"N" ;
11700 [ACASE] IF SUBCOMMAND(ACASE) THEN DELINT←"A" ;
11800 [BCASE] IF SUBCOMMAND(BCASE) THEN SYMNO←BIG!SIZE-1 ;
11900 [HCASE] IF SUBCOMMAND(HCASE) THEN SYMNO←HUGE!SIZE-1 ;
12000 [QUESTCASE]
12100 BEGIN
12200 OUTSTR("PUB SUBCOMMANDS ARE:"&CRLF) ;
12300 FOR N ← 1 THRU SUBCMDS DO
12400 OUTSTR(" "&COMPLETION[N] & SP &
12500 EXPLANATION[N] & CRLF) ;
12600 OUTSTR("CR AFTER EACH, CR AT END"&CRLF) ;
12700 END ;
12800 [CRCASE] DUN ← TRUE
12900 END
13000 END
13100 UNTIL DUN ;
13200 END "SUBCOMMANDS" ;
13300 XCRIBL ← DEVICE = -XGP ;
13400 IF NULSTR(OUTFILE) THEN OUTFILE ← IFILENAME & DOCEXT ;
13500 GENREXT ← FALSE ;
13600 END "TENEXSTART" ;
13700
13800 ELSEC
13900
14000 SIMPLE PROCEDURE ANYSTART(STRING COMDLINE) ; NB Both RPGSTART and SSTART call this one;
14100 BEGIN "ANYSTART"
14200 STRING OPTIONS, N, M, INDEVICE ; INTEGER FIL, EXT, PPN ;
14300 LABEL TRYAGAIN, TRYPART ;
14400 IFC VERSION=ITSVER PJ 5/28/74 ;
14500 THENC SETBREAK(1, "←/()", CR&LF&FF, "INS")
14600 ELSEC SETBREAK(1, "←/()", CR&LF&TB&FF&SP, "INS") ENDC ;
14700 SETBREAK(4, ":", NULL, "IS") ; RKJ: 5-17-74 ;
14800 SETBREAK(2, DIGS, SP, "XNS") ;
14900 SETBREAK(3, ".[", NULL, "INR") ;
15000 OUTFILE ← SCAN(COMDLINE, 1, BRC) ;
15100 IF BRC ≠ "←" THEN BEGIN INFILE ← OUTFILE ; OUTFILE ← NULL END
15400 ELSE INFILE ← SCAN(COMDLINE, 1, BRC) ; TES 8/14/74 SIMPLIFIED;
16300 TRYAGAIN:
16400 RKJ: 5-17-74 Next three lines ;
16500 INDEVICE←SCAN(INFILE,4,DUMMY);
16600 IF NULSTR(INFILE) THEN BEGIN INFILE←INDEVICE; INDEVICE←"DSK" END ;
16700 OPEN(INCHAN←GETCHAN, INDEVICE, 0, 2, 0, 150, BRC, EOF←0) ;
16800 FIL ← CVFIL(INFILE, EXT, PPN) ;
16900 IFILENAME ← CVXSTR(FIL) ;
17000 TRYPART:
17100 IF XLOOKUP(INCHAN, FIL, EXT, 0, PPN) THEN BEGIN END
17200 ELSE IF EXT=0 THEN
17300 BEGIN
17400 EXT←CVSIX(PUBEXT[2 TO ∞]);
17500 IFC VERSION=ITSVER PJ 5/28/74 ;
17600 THENC INFILE←(IF PPN NEQ 0 THEN (CVXSTR(PPN)&";") ELSE NULL)&CVXSTR(FIL)&EXTSEP&PUBEXT;
17700 ELSEC INFILE ← SCAN(INFILE,3,DUMMY) & PUBEXT &
17800 (IF INFILE=EXTSEP THEN INFILE[2 TO ∞] ELSE INFILE);
17900 ENDC
18000 GO TRYPART ;
18100 END
18200 ELSE BEGIN
18300 OUTSTR("No file """ & INDEVICE & ":" & INFILE & """ Read file: ") ;
18400 INFILE ← INCHWL ;
18500 RELEASE(INCHAN) ; RKJ: 5-17-74 ;
18600 GO TRYAGAIN ;
18700 END ;
18800 IF NULSTR(OUTFILE) THEN
18900 BEGIN
19000 OUTFILE ← IFILENAME ;
19100 GENREXT ← TRUE ;
19200 END
19300 ELSE BEGIN
19400 CVFIL(OUTFILE, EXT, PPN) ;
19500 GENREXT ← EXT=0 ;
19600 END ;
19700 TMPFILE ← IFILENAME & RPGEXT ;
19800 WHILE BRC="/" DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) ;
19900 IF BRC = "(" THEN DO OPTIONS ← OPTIONS & SCAN(COMDLINE,1,BRC) & (IF BRC="/" THEN BRC ELSE NULL)
20000 UNTIL BRC = 0 OR BRC = ")" ;
20100 IF FULSTR(OPTIONS) THEN
20200 DO BEGIN
20300 N ← SCAN(OPTIONS, 2, BRC) ;
20400 IF "a"≤BRC≤"z" THEN BRC←BRC-'40; RKJ: 5-10-74 ;
20500 RKJ: 5-10-74 got rid of all lower case below ;
20600 IF BRC = "D" THEN DEBUG ← -1
20700 ELSE IF BRC = "S" THEN PREFMODE ← IF NULSTR(N) THEN 1 ELSE CVD(N)
20800 ELSE IF BRC = "M" THEN DEVICE ← -MIC
20900 ELSE IF BRC = "T" THEN DEVICE ← -TTY
21000 ELSE IF BRC = "L" THEN DEVICE ← -LPT
21100 ELSE IF BRC = "X" THEN DEVICE ← -XGP RKJ;
21200 ELSE IF BRC = "Z" THEN
21300 LSTOP ← SCAN(OPTIONS,1,BRC) & "/" & SCAN(OPTIONS,1,BRC)
21400 ELSE IF BRC="N" ∨ BRC="Y" ∨ BRC="A" THEN DELINT ← BRC
21500 ELSE IF BRC = "B" THEN SYMNO ← BIG!SIZE - 1
21600 ELSE IF BRC = "H" THEN SYMNO ← HUGE!SIZE - 1
21700 ELSE IF BRC = "P" AND OPTIONS = "U" THEN
21800 OPTIONS ← OPTIONS[3 TO ∞] COMMENT /PUB ;
21900 ELSE IF BRC ≠ 0 THEN WARN(NULL,"Never heard of a " & BRC & " option") ;
22000 END
22100 UNTIL BRC = 0 ;
22200 XCRIBL ← (DEVICE = -XGP) ; RKJ;
22300 FOR DUMMY←1 THRU 4 DO BREAKSET(DUMMY, NULL, "O") ; RKJ: 5-17-74 ;
22400 END "ANYSTART" ;
22500
22600 ENDC
00100 IFC NOT TENEX THENC
00200
00300 ifc VERSION=CMUVER thenc
00400 comment This version of RPGSTART by Joe Newcomer;
00500 simple procedure RPGSTART ;
00600 begin "RPGSTART"
00700 comment
00800 This procedure reads a file with the name
00900 nnnPUB.TMP, where nnn is the job number.
01000 Furthermore, it will rewrite any commands
01100 after the first *back* into the file.
01200 If there are no more commands, it deletes
01300 the file. Subsequent phases of PUB will
01400 re-run PUB if the file still exists, otherwise
01500 they will terminate normally.
01600 ;
01700 string CMD,PUBTMP,OTHER!CMDS; integer F1,F2;
01800 EOF ← 0 ; OPEN(0, "DSK", 0, 1, 0, 50, BRC, EOF) ;
01900 GETFORMAT(F1,F2); SETFORMAT(-3,0);
02000 PUBTMP←CVS(CALL(0,"PJOB"))&"PUB.TMP";
02100 SETFORMAT(F1,F2);
02200 LOOKUP(0,PUBTMP,FLAG);
02300 if FLAG then WARN(NULL,"No PUB.TMP file");
02400 SETBREAK(1, LF, CR, "INS") ;
02500 CMD←null;
02600 while length(CMD)=0 do CMD ← INPUT(0,1) ;
02700 comment handles problem of empty command lines;
02800 OTHER!CMDS←NULL;
02900 while not EOF do
03000 OTHER!CMDS←OTHER!CMDS&INPUT(0,1);
03100 if length(OTHER!CMDS)>0 then
03200 begin "rewrite"
03300 integer CHAN;
03400 CHAN←GETCHAN;
03500 EOF←0;
03600 OPEN(CHAN,"DSK" ,0,0,1,0,F1,EOF);
03700 ENTER(CHAN,PUBTMP,FLAG);
03800 if FLAG then
03900 begin "failed"
04000 RENAME(CHAN,null,0,FLAG);
04100 RELEASE(CHAN);
04200 WARN(NULL,"Cannot rewrite PUB.TMP file");
04300 end "failed"
04400 else
04500 begin "writeit"
04600 OUT(CHAN,OTHER!CMDS);
04700 CLOSE(CHAN);
04800 RELEASE(CHAN);
04900 end "writeit";
05000 end "rewrite"
05100 else
05200 RENAME(0,null,0,FLAG);
05300 ANYSTART(CMD) ; RELEASE(0) ;
05400 end "RPGSTART" ;
05500 elsec
05600 SIMPLE PROCEDURE RPGSTART ;
05700 BEGIN "RPGSTART"
05800 STRING CMD ;
05900 EOF ← 0 ; OPEN(0, "DSK", 0, 1, 0, 50, BRC, EOF) ;
06300 LOOKUP(0, "QQPUB"&RPGEXT, FLAG) ; TES 8/14/74 SIMPLIFIED ;
06400 IF FLAG THEN WARN(NULL,"RPG PROBLEM: QQPUB.RPG NONEXISTENT") ;
06700 SETBREAK(1, LF, CR, "INS") ;
06800 CMD ← INPUT(0,1) ;
07700 ANYSTART(CMD) ; RELEASE(0) ;
07800 END "RPGSTART" ;
07900 endc
08000
08100 SIMPLE PROCEDURE SSTART ;
08200 BEGIN "SSTART"
08300 STRING S ;
08400 DO BEGIN OUTCHR("*"); S←INCHWL; END UNTIL FULSTR(S);
08500 ANYSTART(S);
08600 END "SSTART";
08700
08800 ENDC
08900
09000
09100
09200
09300
09400 COMMENT E X E C U T I O N B E G I N S . . . . ;
09500
09600 ONE ← 1 ; NB Variable upper bound for ALIAS arrays;
09700 SYMNO ← REGULAR!SIZE - 1 ; NB Assume for now that symbol table is regular size;
09800 INPGS ← 0 ; INFILE ← NULL ; PREFMODE ← 1 ; DELINT ← "Y" ;
09900 DEVICE ← IFC VERSION=PARCVER THENC TTY ELSEC LPT ENDC ;
10000 IFC TENEX THENC
10100 TENEXSTART ;
10200 ELSEC
10300 IF RPGSW THEN RPGSTART ELSE SSTART; NB Read file names and options;
10400 ENDC
10500 INITSIZES ;
00100 BEGIN "VARIABLE BOUND ARRAY BLOCK"
00200
00300 REQUIRE "PUBINR" SOURCE!FILE ;
00400 comment, Arrays whose sizes depend on CUSP options. Also SYMSER.SAI variables ;
00500
00600 COMMENT
00700 SYMSER.SAI package -- LOOKUP and ENTER procedures for hashed
00800 symbol tables -- STRINGS -- uses quadratic search.
00900
01000 REQUIRED --
01100 1. DEFINE SYMNO="1 less than some relatively prime number big
01200 enough to hold all entries"
01300 2. REQUIRE "SYMSER.SAI[1,DCS]" SOURCE!FILE in outer block
01400 declaration code
01500
01600 WHAT YOU GET ---
01700 1. An array, SYM, to hold the (STRING) symbols you enter.
01800 2. Another array, NUMBER, to hold the (INTEGER) values
01900 associated with the array
02000 3. An index, SYMBOL, set to the correct SYM/NUMBER element
02100 after a lookup
02200
02300 4. An integer, ERRFLAG, set to TRUE if errors occur in ENTERSYM
02400
02500
02600 5. A Procedure, FLAG←LOOKSYM("A") which returns:
02700 TRUE if the symbol is already present in the SYM table.
02800 FALSE if the symbol is not found --
02900 SYMBOL will have the value -1 (table full), or
03000 will be an index of a free entry (see ENTERSYM)
03100
03200 6. A Procedure, ENTERSYM("SYM",VAL) which does:
03300 Checks for symbol full or duplicate symbol -- if detected,
03400 types message and sets ERRFLAG TRUE
03500 Puts SYM and VAL in SYM/NUMBER arrays at SYMBOL index
03600
03700 7. A Procedure, SYMSET, which initializes the table.
03800 SYM[0] is initted to a blank string -- you can use
03900 this information if you wish.
04000
04100 ;
00100 COMMENT Most of the procedures in this block are INTERNAL. They are EXTERNAL in PUBPRO.SAI ;
00200
00300 INTERNAL SIMPLE PROCEDURE SETSYM;
00400 BEGIN "SETSYM"
00500 INTEGER I;
00600 FOR I← 1 STEP 1 UNTIL SYMNO DO SYM[I]←NULL;
00700 SYM[0]←" ";
00800 ERRFLAG←FALSE
00900 END "SETSYM";
01000
01100 INTERNAL INTEGER SIMPLE PROCEDURE LOOKSYM(STRING A);
01200 BEGIN "LOOKSYM"
01300 INTEGER H,Q,R;
01400 DEFINE SCON="10";
01500 H←CVASC(A) +LENGTH(A) LSH 6;
01600 R←SYMBOL←(H←ABS(H⊗(H LSH 2))) MOD (SYMNO+1);
01700
01800 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
01900 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02000
02100 Q←H%(SYMNO+1) MOD (SYMNO+1);
02200 IF (H←Q+SCON)≥SYMNO THEN H←H-SYMNO;
02300
02400 WHILE (IF (SYMBOL←SYMBOL+H)>SYMNO
02500 THEN SYMBOL←SYMBOL-(SYMNO+1) ELSE SYMBOL) ≠R DO
02600 BEGIN "LK1"
02700 IF EQU(SYM[SYMBOL],A) THEN RETURN(-1);
02800 IF NULSTR(SYM[SYMBOL]) THEN RETURN(0);
02900 IF (H←H+Q)>SYMNO THEN H←H-(SYMNO+1);
03000 END "LK1";
03100 SYMBOL←-1; RETURN(0);
03200 END "LOOKSYM";
03300
03400 INTERNAL SIMPLE PROCEDURE ENTERSYM(STRING WORD; INTEGER VAL);
03500 BEGIN "ENTERSYM"
03600 IF LENGTH(SYM[SYMBOL])∨SYMBOL<0 THEN
03700 BEGIN
03800 ERRFLAG←1;
03900 IF SYMBOL≥0 THEN PRINT "DUPLICATE SYMBOL "&WORD MSG
04000 ELSE PRINT "SYMBOL TABLE FULL" MSG ;
04100 END
04200 ELSE
04300 BEGIN
04400 SYM[SYMBOL]←WORD;
04500 NUMBER[SYMBOL]←VAL;
04600 END;
04700 END "ENTERSYM";
04800
04900 FORWARD INTERNAL RECURSIVE BOOLEAN PROCEDURE STATEMENT ;
05000 FORWARD INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR; INTEGER NEWINPUTCHAN, ARGS) ;
05100 FORWARD INTERNAL SIMPLE STRING PROCEDURE SWICHBACK ;
05200 EXTERNAL RECURSIVE STRING PROCEDURE PASS ; comment, INTERNAL in PARSER.SAI ;
05300
05400 IFC VERSION=ITSVER THENC
05500 SIMPLE PROCEDURE LOSERR(INTEGER RSP) ;
05600 BEGIN
05700 DEFINE !BREAK = " '45000000000" ;
05800 EXTERNAL INTEGER JOBSA ;
05900
06000 IF RSP="X"
06100 THEN START!CODE !BREAK '16,'40000 END
06200 ELSE IF RSP="S"
06300 THEN START!CODE MOVE 1,JOBSA; JRST (1) END
06400 ELSE IF RSP="D" THEN START!CODE !BREAK '16,'3000000 END;
06500 END "LOSERR";
06600 ENDC
06700
06800
06900 INTERNAL SIMPLE INTEGER PROCEDURE ERROR (INTEGER LOC; STRING MESG, RSP);
07000 BEGIN "ERROR" RKJ 6/25/74 TES 8/20/74 ;
07100 COMMENT SAIL CALLS ERROR(LOC,CRLF&MESG&CRLF,NULL),
07200 WARN CALLS ERROR(0,MESG,NULL),
07300 OTHERS CALL ERROR(0,MESG|NULL,RSP) ;
07400 EXTERNAL INTEGER !JBSA,!JBDDT;
07500 INTEGER CHAR;
07600 DEFINE CLRBFI="START!CODE TTCALL '11,0 END";
07700 IF LOC=0 AND NOT SWDBACK THEN OUTSTR(CRLF) ; SWDBACK←TRUE;
07800 IF FULSTR(MESG) THEN BEGIN OUTSTR(MESG); IF LOC=0 THEN OUTSTR(CRLF) END ;
07900 IF NOT ERRLF THEN
08000 IF (CHAR←INCHRS)=LF
08100 THEN ERRLF←TRUE;
08200 IF LOC THEN OUTSTR(
08300 "This is a SAIL error -- Probably a PUB bug. Called from location "&CVOS(LOC)&CRLF) ;
08400 OUTSTR("Line/Page "&ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]"&CRLF) ;
08500 CHAR ← RSP ;
08600 IF NOT ERRLF THEN
08700 WHILE TRUE DO
08800 BEGIN "ERRLOOP"
08900 IF NOT CHAR THEN
09000 BEGIN
09100 OUTCHR("↑");
09200 IFC TENEX THENC CLRBUF ELSEC CLRBFI ENDC ;
09300 CHAR ← INCHRW ;
09400 IF "a" LEQ CHAR LEQ "z" THEN CHAR ← CHAR LAND '137 ;
09500 END ;
09600 IF CHAR=CR THEN BEGIN INCHWL; CHAR←0; DONE END ELSE
09700 IF CHAR="C" OR CHAR='37 THEN BEGIN CHAR←0; DONE END ELSE
09800 IF CHAR=LF OR CHAR="A" THEN BEGIN ERRLF←TRUE; CHAR←0; DONE END ELSE
09900 IF CHAR="X" THEN DONE ELSE
10000 IF CHAR="S" THEN DONE ELSE
10100 IF CHAR="D" THEN
10200 IFC TENEX THENC DONE ELSE ELSEC
10300 BEGIN
10400 IF !JBDDT NEQ 0
10500 THEN DONE
10600 ELSE OUTSTR(CRLF&"No DDT"&CRLF);
10700 END ELSE
10800 ENDC
10900 IF CHAR="E" THEN CALLEDITOR(IFC VERSION=SAILVER THENC "SOS" ELSEC "LINED" ENDC) ELSE
11000 IFC VERSION=SAILVER THENC
11100 IF CHAR="T" THEN CALLEDITOR("E") ELSE
11200 ENDC
11300 IF CHAR="P" THEN
11400 BEGIN TES: PUB INTERACTIVE DEBUGGER ;
11500 INTEGER LASTWAS, TEXTWAS, BRCWAS ;
11600 LASTWAS←LAST ; TEXTWAS←TEXTMODE ;
11700 OUTSTR(CRLF&"= = = = ="&CRLF) ;
11800 !ERRP! ← 0 ; COMMENT PREVENT RECURSION ;
11900 SWICH("START PUB!DEBUG END;;" &
12000 (IF NOT TEXTMODE THEN CRLF&TB&TB
12100 ELSE RCBRAK), -1, 0) ; TES 8/23/74;
12200 TEXTMODE ← 0 ; TES 8/23/74 ;
12300 PASS ; STATEMENT ;
12400 !ERRP! ← LOCATIONOFERROR ;
12500 OUTSTR("= = = = ="&CRLF) ;
12600 IF TEXTWAS THEN
12700 BEGIN
12800 WHILE LAST>LASTWAS DO SWICHBACK ;
12900 EMPTYTHIS ; EMPTYTHAT ;
13000 TEXTMODE ← TRUE ; BRC ← BRCWAS ;
13100 END ;
13200 CHAR←0;
13300 END
13400 ELSE
13500 BEGIN
13600 OUTSTR(CRLF&"Reply <CR> to continue,
13700 <LF> to continue automatically,"&CRLF);
13800 IF !JBDDT NEQ 0 THEN OUTSTR("""D"" to enter DDT, ");
13900 IFC VERSION=SAILVER THENC
14000 OUTSTR("""E"" or ""T"" to EDIT,"&
14100 ELSEC
14200 OUTSTR("""E"" to EDIT,"&
14300 ENDC
14400 """P"" to enter PUB debug loop," & CRLF &
14500 """X"" to exit, ""S"" to start over"&CRLF);
14600 END;
14700 CHAR ← 0 ;
14800 END "ERRLOOP" ;
14900 IF LOC OR NOT CHAR THEN RETURN(CHAR + 3 LSH 18)
15000 ELSE BEGIN "BUGGY"
15100 !ERRP! ← LOCATION(NERROR) ; COMMENT SIMPLE PROCEDURES CAN'T RECURSE ;
15200 IFC VERSION = ITSVER THENC
15300 LOSERR(CHAR) ;
15400 ELSEC
15500 USERERR(0, 1, NULL, CHAR) ;
15600 ENDC
15700 !ERRP! ← LOCATIONOFERROR ;
15800 RETURN(0) ;
15900 END "BUGGY" ;
16000 END "ERROR";
16100
16200 INTERNAL STRING SIMPLE PROCEDURE WARN(STRING SHORT!VERSION,LONG!VERSION) ;
16300 BEGIN "WARN"
16400 IF !ERRP! THEN ERROR(0, LONG!VERSION, NULL)
16500 ELSE USERERR(0, 1, LONG!VERSION) ; COMMENT PREVENT RECURSION ;
16600 IF DEBUG ∧ MESGS<MESSMAX ∧ LENGTH(SHORT!VERSION) THEN
16700 MESSAGE[MESGS←MESGS+1] ← IF SHORT!VERSION = "=" THEN LONG!VERSION ELSE SHORT!VERSION ;
16800 RETURN(NULL) ;
16900 END "WARN" ;
00100 COMMENT P A S S O N E P R O C E D U R E S - - - - - - - - - - - - - - - ;
00200
00300 EXTERNAL SIMPLE PROCEDURE SELECTFONT(INTEGER WHICH);
00400 EXTERNAL RECURSIVE PROCEDURE DBREAK ;
00500 EXTERNAL RECURSIVE BOOLEAN PROCEDURE TEXTLINE ; comment, INTERNAL in FILLER.SAI ;
00600 EXTERNAL RECURSIVE BOOLEAN PROCEDURE CHUNK(BOOLEAN VALID) ;
00800 EXTERNAL STRING SIMPLE PROCEDURE EVALV(STRING THISWD ; INTEGER IX, TYP) ;
00900 EXTERNAL RECURSIVE STRING PROCEDURE E(STRING DEFAULT, STOPWORD) ;
01000 EXTERNAL SIMPLE PROCEDURE RDENTITY ;
01100 EXTERNAL SIMPLE STRING PROCEDURE PICKFONT(INTEGER F) ; TES 11/29/73;
01200 EXTERNAL SIMPLE INTEGER PROCEDURE RFONT(INTEGER F) ; TES 11/29/73;
01300
01400 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01500 FORWARD INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01600
01700 INTERNAL STRING SIMPLE PROCEDURE SOMEINPUT ;
01800 RETURN(SP&THISWD&SP&
01900 (IF THATISFULL THEN LIT!ENTITY&LIT!TRAIL ELSE NULL)&INPUTSTR[1 TO 80]);
02000
02100 INTERNAL SIMPLE PROCEDURE IMPOSSIBLE(STRING WHERE); WARN("=","Impossible CASE index in "&WHERE&" at "&SOMEINPUT);
02200
02300 INTERNAL STRING SIMPLE PROCEDURE CAPITALIZE(STRING MIXEDCASE) ;
02400 BEGIN "CAPITALIZE"
02500 INTEGER C ; STRING S ; S ← 0&MIXEDCASE ; LOPP(S) ; C ← LENGTH(MIXEDCASE) ; IF ¬C THEN RETURN(NULL);
02600 START!CODE "CAPIT" LABEL NEXC ; MOVE 1, S ; MOVE 2, C ;
02700 NEXC: ILDB 3, 1 ; LDB 3, UPCAS3 ; DPB 3, 1 ; SOJG 2, NEXC ;
02800 END "CAPIT" ; RETURN(S) ;
02900 END "CAPITALIZE" ;
03000
03100 SIMPLE PROCEDURE ZEROWORDS(INTEGER WDS; REFERENCE INTEGER LOCN) ;
03200 BEGIN "ZEROWORDS"
03300 START!CODE "ZOT"
03400 LABEL DUN ;
03500 SKIPG 1, WDS ;
03600 JRST DUN ; COMMENT NO WDS TO ZERO -- QUIT ;
03700 HRRZ 2, -1('17) ; COMMENT LOCN ;
03800 SETZM 0(2) ;
03900 CAIN 1, 1 ;
04000 JRST DUN ; COMMENT ONLY 1 -- DON'T BLT ! ;
04100 ADDI 1, -1(2) ;
04200 HRL 2, 2 ;
04300 ADDI 2, 1 ;
04400 BLT 2, (1) ;
04500 DUN:
04600 END ;
04700 END "ZEROWORDS" ;
04800
04900 INTERNAL SIMPLE PROCEDURE ZEROSTRINGS(INTEGER STRS; REFERENCE STRING LOCN) ;
05000 BEGIN
05100 START!CODE "ZOS"
05200 LABEL DUN ;
05300 SKIPG 1, STRS ;
05400 JRST DUN ; COMMENT NO STRS TO ZERO -- QUIT ;
05500 ADD 1, 1 ; COMMENT TWO WORDS PER STRING ;
05600 HRRZ 2, -1('17) ; COMMENT LOCN ;
05700 SUBI 2, 1 ; COMMENT POINT TO COUNT WORD FIRST ;
05800 SETZM 0(2) ;
05900 ADDI 1, -1(2) ;
06000 HRL 2, 2 ;
06100 ADDI 2, 1 ;
06200 BLT 2, (1) ;
06300 DUN:
06400 END ;
06500 END "ZEROSTRINGS" ;
06600
00100 INTERNAL SIMPLE PROCEDURE GROW(REFERENCE INTEGER ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00200 INTEGER EXTRA; STRING WHY) ;
00300 BEGIN "GROW"
00400 IDA ← RH("BIGGER(WHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
00500 IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
00600 END "GROW" ;
00700
00800 INTERNAL SIMPLE PROCEDURE SGROW(REFERENCE STRING ARRAY ARR; REFERENCE INTEGER IDA,WDS;
00900 INTEGER EXTRA; STRING WHY) ;
01000 BEGIN "SGROW"
01100 IDA ← RH("SBIGGER(SWHATIS(ARR),EXTRA)"); WDS ← WDS + EXTRA ;
01200 IF WDS ≥ TWO(14) THEN WARN(NULL,"Table grown to 2↑14 entries. Utterly unmanageable. Goodbye!") ;
01300 END "SGROW" ;
01400
01500 INTERNAL SIMPLE PROCEDURE GROWNESTS ;
01600 BEGIN "GROWNESTS"
01700 GROW(INEST, INESTIDA, SIZE, 200, NULL) ; MAKEBE(INESTIDA, INEST) ;
01800 DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM SGROW 2/28/73 TES ;
01900 SGROW(SNEST, SNESTIDA, DUMMY, 200, NULL) ; SMAKEBE(SNESTIDA, SNEST) ;
02000 ZEROSTRINGS(200, SNEST[SIZE-199]) ;
02100 END "GROWNESTS" ;
02200
02300 INTERNAL SIMPLE PROCEDURE GROWOWLS(INTEGER EXTRA) ;
02400 BEGIN "GROWOWLS"
02500 GROW(MOLES, MOLESIDA, OLXX, EXTRA, NULL) ; MAKEBE(MOLESIDA, MOLES) ;
02600 GROW(SHORT, SHORTIDA, DUMMY←0, EXTRA, NULL) ; MAKEBE(SHORTIDA, SHORT) ;
02700 DUMMY ← 0 ; COMMENT OTHERWISE SPURIOUS MESSAGE FROM GROW 2/28/73 TES ;
02800 GROW(OWLS, OWLSIDA, DUMMY, EXTRA, NULL) ;
02900 MAKEBE(OWLSIDA, OWLS) ; OWLSF ← OWLSIDA ; MOLESF ← MOLESIDA ; SHORTF ← SHORTIDA ;
03000 END "GROWOWLS" ;
03100
03200 INTERNAL INTEGER SIMPLE PROCEDURE PUSHI(INTEGER WDS, TYP) ;
03300 BEGIN "PUSHI"
03400 INTEGER QI ;
03500 IF (IHED ← IHED + WDS+1) > ISIZE THEN
03600 BEGIN
03700 GROW(ISTK, ISTKIDA, ISIZE, 1000, NULL) ;
03800 MAKEBE(ISTKIDA,ISTK)
03900 END ;
04000 ISTK[IHED] ← TYP ROT -9 LOR (IHED-WDS-1) ;
04100 ZEROWORDS(WDS, ISTK[IHED-WDS]) ; RETURN(IHED) ;
04200 END "PUSHI" ;
04300
04400 INTERNAL INTEGER SIMPLE PROCEDURE PUSHS(INTEGER WDS; STRING FIRST) ;
04500 BEGIN"PUSHS"
04600 INTEGER QI ;
04700 IF (SHED ← SHED + WDS) > SSIZE THEN
04800 BEGIN
04900 SGROW(SSTK, SSTKIDA, SSIZE, 200, NULL) ;
05000 SMAKEBE(SSTKIDA,SSTK) ; ZEROSTRINGS(200, SSTK[SSIZE-199]) ;
05100 END ;
05200 SSTK[SHED] ← FIRST ;
05300 FOR QI←WDS-1 DOWN 1 DO SSTK[SHED-QI]←NULL ; RETURN(SHED) ;
05400 END "PUSHS" ;
05500
05600 INTERNAL INTEGER SIMPLE PROCEDURE PUTI(INTEGER WDS, FIRST) ;
05700 BEGIN"PUTI"
05800 INTEGER QI ;
05900 IF (IHIGH ← IHIGH + WDS) > ITSIZE THEN
06000 BEGIN
06100 GROW(ITBL, ITBLIDA, ITSIZE, 300, NULL) ;
06200 MAKEBE(ITBLIDA,ITBL) ;
06300 END ;
06400 ITBL[IHIGH] ← FIRST ;
06500 ZEROWORDS(WDS-1, ITBL[IHIGH-WDS+1]) ; RETURN(IHIGH) ;
06600 END "PUTI" ;
06700
06800 INTERNAL INTEGER SIMPLE PROCEDURE PUTS(STRING VAL) ;
06900 BEGIN"PUTS"
07000 INTEGER QI ;
07100 IF (SHIGH ← SHIGH + 1) > STSIZE THEN
07200 BEGIN
07300 SGROW(STBL, STBLIDA, STSIZE, 200, NULL) ;
07400 SMAKEBE(STBLIDA,STBL) ; ZEROSTRINGS(200, STBL[STSIZE-199]) ;
07500 END ;
07600 STBL[SHIGH] ← VAL ;
07700 RETURN(SHIGH) ;
07800 END "PUTS" ;
00100 INTERNAL SIMPLE PROCEDURE SWICH(STRING NEWINPUTSTR; INTEGER NEWINPUTCHAN, ARGS) ;
00200 BEGIN "SWICH" comment switch to new input stream ;
00300 IF ARGS THEN
00400 BEGIN "SUBSTITUTE"
00500 INTEGER BRC ; STRING NEWER ; NEWER ← NULL ; LAST ← LAST - ARGS ;
00600 DO BEGIN "VTABS"
00700 NEWER ← NEWER & SCAN(NEWINPUTSTR, TO!VT!SKIP, BRC) ;
00800 IF BRC THEN NEWER ← NEWER & SNEST[LAST + LOP(NEWINPUTSTR)] ;
00900 END "VTABS"
01000 UNTIL BRC = 0 ;
01100 NEWINPUTSTR ← NEWER ;
01200 END "SUBSTITUTE" ;
01300 IF (LAST ← LAST+2) > SIZE THEN GROWNESTS ;
01400 STRSCAN(LAST) ← IF THATISFULL THEN LIT!ENTITY & LIT!TRAIL & INPUTSTR ELSE INPUTSTR ;
01500 CHANSCAN(LAST) ← INPUTCHAN + (IF TECOFILE THEN 100 ELSE 0) ;
01600 LINESCAN(LAST) ← IF INPUTCHAN < 0 THEN MACLINE ELSE THISFILE & VT & SRCLINE ;
01700 PAGESCAN(LAST) ← LHRH(PAGEMARKS, PAGEWAS) ;
01800 EMPTYTHIS ; EMPTYTHAT ;
01900 INPUTSTR ← NEWINPUTSTR ; INPUTCHAN ← NEWINPUTCHAN ; TECOFILE ← 0 ;
02000 END "SWICH" ;
02100
02200 INTERNAL STRING SIMPLE PROCEDURE SWICHBACK ;
02300 BEGIN "SWICHBACK"
02400 EOF ← 0 ; IF INPUTCHAN≥0 THEN
02500 BEGIN
02600 IF PUBSTD THEN PUBSTD ← FALSE
02700 ELSE IF SWFLG AND NOT SWDBACK THEN BEGIN OUTSTR("."&CRLF) ; SWDBACK←TRUE END ;
02800 RELEASE(INPUTCHAN) ;
02900 END
02950 ELSE IF CHANSCAN(LAST) LEQ -2 THEN RETURN(INPUTSTR←STRSCAN(LAST)) ;
03000 PAGEMARKS ← LH("DUMMY ← ABS(PAGESCAN(LAST))") ; PAGEWAS ← RH(DUMMY) ;
03100 SRCPAGE ← CVS(PAGEMARKS) ;
03200 IF (INPUTCHAN ← CHANSCAN(LAST))< 0 THEN MACLINE←LINESCAN(LAST)
03300 ELSE BEGIN SRCLINE←LINESCAN(LAST);
03400 THISFILE←SCAN(SRCLINE,TO!VT!SKIP,DUMMY) END ;
03500 IF TECOFILE ← INPUTCHAN > 50 THEN INPUTCHAN ← INPUTCHAN - 100 ;
03600 INPUTSTR ← STRSCAN(LAST) ; LAST←LAST-2; RETURN(INPUTSTR) ;
03700 END "SWICHBACK" ;
03800
03900 SIMPLE PROCEDURE SWICHFILE(STRING FILENAME ; INTEGER CHAN) ;
04000 BEGIN COMMENT FILE ALREADY OPEN ON CHAN ;
04100 TES 1/22/74 SUBROUTINIZED ; TES 3/23/74 SIMPLIFIED ;
04200 SWICH(NULL, CHAN, 0) ;
04300 IF AGENFILE THEN BEGIN TECOFILE←0 ; AGENFILE←FALSE END
04400 ELSE BEGIN INPUT(INPUTCHAN, NO!CHARS) ; TECOFILE ← BRC≥0 END ;
04500 PAGEMARKS ← PAGEWAS ← 1 ; SRCPAGE ← "1" ; SRCLINE ← IF TECOFILE THEN "0" ELSE "00000" ;
04600 IFC VERSION = SAILVER THENC
04700 IF TECOFILE THEN
04800 BEGIN COMMENT IF TVEDIT FILE, SKIP PAGE 1 ;
04900 IF EQU("COMMENT ⊗", INPUT(INPUTCHAN,TO!TERQ!CR)[1 TO 9]) THEN
05000 BEGIN
05100 DO INPUT(INPUTCHAN, TO!TB!FF!SKIP) UNTIL BRC=FF ;
05200 SRCPAGE ← "2" ; PAGEMARKS ← PAGEWAS ← 2 ;
05300 END
05400 ELSE BEGIN CLOSIN(INPUTCHAN) ; COMMENT NOT TVEDIT -- RESTART INPUT ;
05500 LOOKUP(CHAN,FILENAME,FLAG);
05600 END END ;
05700 ENDC
05800 THISFILE ← FILENAME ;
05900 IF NOT PUBSTD THEN
06000 BEGIN
06100 IF LAST =4 AND SWFLG=0 THEN TES ADDED SWFLG 12/5/73 ;
06200 BEGIN MAINFILE←THISFILE ; SWFLG ← 1 END
06300 ELSE BEGIN IF NOT SWDBACK THEN OUTSTR(CRLF) ; OUTSTR(SPS(LAST-4)) ; END ;
06400 OUTSTR(THISFILE&SP&SRCPAGE) ; SWDBACK ← FALSE ;
06500 END ;
06600 END "SWICHFILE" ;
06700
06800 INTERNAL SIMPLE PROCEDURE SWICHF(STRING FILENAME) ;
06900 BEGIN "SWICHF"
07000 INTEGER CHAN ;
07100 STRING INDEVICE ; RKJ: 5-17-74 ;
07200 IFC TENEX THENC
07300 CHAN ← OPENFILE(FILENAME, "ROE") ;
07400 IF CHAN=-1 AND FILENAME NEQ "<" THEN CHAN←OPENFILE(INPPN&FILENAME, "ROE") ;
07500 IF CHAN=-1 THEN BEGIN
07600 OUTSTR("No file """ & FILENAME & """ Read file: ") ;
07700 CHAN ← OPENFILE(NULL, "ROC") ;
07800 END ;
07900 FILENAME ← JFNS(CHAN, 0) ;
08000 EOF ← 0 ; SETINPUT(CHAN, 150, BRC, EOF) ;
08100 ELSEC
08200 IF (CHAN ← GETCHAN) < 0 THEN
08300 BEGIN WARN("=","No channel for reading "&FILENAME) ; RETURN END ;
08400 EOF ← 0 ;
08500 RKJ: 5-17-74 Start of allow device in filename ;
08600 SETBREAK(LOCAL!TABLE,":",NULL,"IS");
08700 INDEVICE←SCAN(FILENAME,LOCAL!TABLE,DUMMY);
08800 IF NULSTR(FILENAME) THEN BEGIN FILENAME←INDEVICE; INDEVICE←"DSK" END;
08900 OPEN(CHAN, INDEVICE, 0, 2, 0, 150, BRC, EOF←0) ;
09000 DO BEGIN
09100 LOOKUP(CHAN,FILENAME,FLAG);
09200 RKJ: 5-17-74 End of device code ;
09300 IF FLAG THEN BEGIN
09400 OUTSTR("No file """&INDEVICE&":"&FILENAME&""" Read file: ") ;
09500 FILENAME←INCHWL ;
09600 END ;
09700 END
09800 UNTIL ¬FLAG ;
09900 ENDC
10000 SWICHFILE(FILENAME, CHAN) ; TES 1/22/74 SUBROUTINIZED 3/23/74 REVISED;
10100 END "SWICHF" ;
00100 INTERNAL BOOLEAN SIMPLE PROCEDURE SYMLOOK(STRING NAME) ;
00200 BEGIN "SYMLOOK" comment same as LOOKSYM, but if hash table full, expands it and does linear search ;
00300 comment don't search if it's already here;
00400 IF SYMBOL>0 AND EQU(SYM[SYMBOL],NAME) OR LOOKSYM(NAME) THEN RETURN(TRUE) ;
00500 IF SYMBOL>0 THEN RETURN(FALSE) ; comment it's not there, and table's not full;
00600 FOR SYMBOL ← SYMNO STEP 1 WHILE SYMBOL≤XSYMNO AND FULSTR(SYM[SYMBOL]) AND ¬EQU(SYM[SYMBOL],NAME) DO ;
00700 IF SYMBOL > XSYMNO THEN
00800 BEGIN
00900 SGROW(SYM, SYMIDA, XSYMNO, 1000, "Symbol Table Full") ; SMAKEBE(SYMIDA, SYM) ;
01000 ZEROSTRINGS(1000, SYM[XSYMNO-999]) ;
01100 GROW(NUMBER, NUMBIDA, DUMMY, 1000, NULL) ; MAKEBE(NUMBIDA, NUMBER) ;
01200 ZEROWORDS(1000, NUMBER[XSYMNO-999]); RKJ: 1-3-74;
01300 IF XSYMNO≥TWO(13) THEN WARN(NULL,"Symbol Table Enormopotamus. I give up.") ;
01400 RKJ: SUPERFLUOUS 1-3-74 FOR SYMBOL ← XSYMNO-999 THRU XSYMNO DO SYM[SYMBOL] ← NULL ;
01500 DUMMY←XSYMNO+1; SYMBOL ← XSYMNO - 999 ; RETURN(FALSE) ;
01600 END
01700 ELSE RETURN(FULSTR(SYM[SYMBOL])) ;
01800 END "SYMLOOK" ;
01900
02000 INTERNAL INTEGER SIMPLE PROCEDURE SYMNUM(STRING NAME) ;
02100 BEGIN "SYMNUM" comment looks up a symbol, and if not there, enters it. returns subscript;
02200 IF ¬SYMLOOK(NAME) THEN ENTERSYM(NAME, 0) ;
02300 RETURN(SYMBOL) ;
02400 END "SYMNUM" ;
02500
02600 INTERNAL BOOLEAN SIMPLE PROCEDURE SIMLOOK(STRING NAME) ;
02700 comment, SIMilar to SYMLOOK, but sets SYMTYPE and SYMIX ;
02800 IF SYMLOOK(NAME) THEN
02900 BEGIN
03000 BYTEWD ← NUMBER[SYMBOL] ;
03100 SYMTYPE ← LDB(TYPEWD(BYTEWD)) ; SYMIX ← LDB(IXWD(BYTEWD)) ;
03200 RETURN(TRUE) ;
03300 END
03400 ELSE RETURN(FALSE) ;
03500
03600 INTERNAL INTEGER SIMPLE PROCEDURE SIMNUM(STRING NAME) ;
03700 BEGIN "SIMNUM" comment, SIMilar to SYMNUM, but uses SIMLOOK instead of SYMLOOK ;
03800 IF ¬SIMLOOK(NAME) THEN ENTERSYM(NAME, SYMTYPE←SYMIX←0) ;
03900 RETURN(SYMBOL) ;
04000 END "SIMNUM" ;
04100
04200 INTERNAL INTEGER SIMPLE PROCEDURE WRITEON(BOOLEAN BINARY; STRING FILENAME) ;
04300 BEGIN "WRITEON"
04400 INTEGER CH ;
04500 IF (CH ← GETCHAN) < 0 THEN RETURN(WARN("=","No channel for writing "&FILENAME));
04600 K ← 0 ; OPEN(CH, "DSK", IF BINARY THEN 8 ELSE 0, 0, 2, DUMMY, DUMMY, K) ;
04700 ENTER(CH, FILENAME, DUMMY←0) ;
04800 IF DUMMY THEN WARN("=","ENTER failed for "&FILENAME);
04900 RETURN(CH) ;
05000 END "WRITEON" ;
00100 INTEGER SIMPLE PROCEDURE LOG2(INTEGER BINARY) ;
00200 BEGIN "LOG2"
00300 INTEGER I ; I ← 0 ;
00400 WHILE BINARY > 1 DO BEGIN I ← I + 1 ; BINARY ← BINARY DIV 2 END ;
00500 RETURN(I) ;
00600 END "LOG2" ;
00700
00800 INTEGER SVSHED ; comment, value of SHED before Alphabetizing began ;
00900 BOOLEAN SIMPLE PROCEDURE STRLSS(INTEGER XI, YI) ;
01000 BEGIN "STRLSS"
01100 INTEGER XL, YL, MINL, L ; STRING X, Y ;
01200 X ← SSTK[SVSHED + XI] ; Y ← SSTK[SVSHED + YI] ;
01300 XL ← LENGTH(X) ; YL ← LENGTH(Y) ; MINL ← XL MIN YL ;
01400 START!CODE "STRCOM"
01500 LABEL NEXC, SAME, DIFF ;
01600 MOVE 2, X ; MOVE 3, Y ; SKIPN 4, MINL ; JRST SAME ;
01700 NEXC: ILDB 5, 2 ; LDB 5, UPCAS5 ; ILDB 6, 3 ; LDB 6, UPCAS6 ;
01800 CAME 5, 6 ; JRST DIFF ; SOJG 4, NEXC ;
01900 SAME: COMMENT SAME FOR FIRST MINL CHARACTERS ;
02000 MOVE 5, XL ; MOVE 6, YL ; CAME 5, 6 ; JRST DIFF ;
02100 COMMENT AND SAME LENGTH: ; MOVE 5, XI ; MOVE 6, YI ;
02200 DIFF: CAML 5, 6 ; TDZA 1,1 ; MOVEI 1, -1 ; MOVEM 1, L ;
02300 END ;
02400 RETURN(L) ;
02500 END "STRLSS" ;
02600
02700 PROCEDURE QUICKERSORT(INTEGER J, BASE) ;
02800 BEGIN "QUICKERSORT" comment, Ascending SORT for ALFIZE ;
02900 INTEGER I, K, Q, M, P, T, X ; INTEGER ARRAY UT,LT[1:LOG2(J+2)+1] ;
03000 COMMENT Algorithm 271 (R. S. Scowen) CACM 8,11 (Nov. 1965) pp 669-670 ;
03100 DEFINE A(L) = "ITBL[BASE+L]" ;
03200 LABEL N, L, MM, PP ;
03300 I ← M ← 1 ;
03400 N: IF J-I > 1 THEN
03500 BEGIN
03600 P ← (J+I) DIV 2 ; T ← A(P) ; A(P) ← A(I) ; Q ← J ;
03700 FOR K ← I + 1 THRU Q DO
03800 BEGIN
03900 IF STRLSS(T, A(K)) THEN
04000 BEGIN
04100 FOR Q ← Q DOWN K DO
04200 BEGIN
04300 IF STRLSS(A(Q), T) THEN
04400 BEGIN
04500 A(K) ↔ A(Q) ; Q ← Q - 1 ;
04600 GO TO L ;
04700 END ;
04800 END ;
04900 Q ← K - 1 ;
05000 GO TO MM ;
05100 END ;
05200 L:
05300 END ;
05400 MM:
05500 A(I) ← A(Q) ; A(Q) ← T ;
05600 IF Q+Q > I+J THEN BEGIN LT[M]←I; UT[M]←Q-1; I←Q+1 END
05700 ELSE BEGIN LT[M]←Q+1; UT[M]←J; J←Q-1 END ;
05800 M ← M + 1 ;
05900 GO TO N ;
06000 END
06100 ELSE IF I≥J THEN GO TO PP
06200 ELSE BEGIN
06300 IF STRLSS(A(J),A(I)) THEN A(I)↔A(J) ;
06400 PP: M ← M - 1 ;
06500 IF M > 0 THEN BEGIN I←LT[M]; J←UT[M]; GO TO N END ;
06600 END ;
06700 END "QUICKERSORT" ;
00100 INTERNAL SIMPLE PROCEDURE DAPART ; IF ON THEN
00200 BEGIN "DAPART"
00300 DBREAK ; GLINEM ← 0 ; COMMENT ← TES 4/25/73 ; IF GROUPM=0 THEN RETURN ;
00400 IF MOLESIDA THEN DPB(0,BELOWM(OLX)) ; GROUPM←0 ;
00500 END "DAPART" ;
00600
00700 INTERNAL SIMPLE PROCEDURE MAKEPAGE(INTEGER HIGH, WIDE) ;
00800 BEGIN "MAKEPAGE"
00900 IDASSIGN("FRAMEIDA←CREATE(0,PFREC)", THISFRAME) ;
01000 HIGHF ← HIGH; WIDEF ← WIDE;
01100 END "MAKEPAGE" ;
01200
01300 INTERNAL SIMPLE PROCEDURE MAKEAREA(INTEGER ITSIX) ;
01400 BEGIN "MAKEAREA"
01500 INTEGER C, L, CS, LS, NCH, OCH, C1, CC, FW, L1, LC, FH ;
01550 C1 ← CHAR1(ITSIX) ; CC ← CHARCT(ITSIX) ;
01560 FW ← IF FRAMEIDA THEN WIDEF ELSE FWIDE ;
01570 L1 ← LINE1(ITSIX) ; LC ← LINECT(ITSIX) ;
01580 FH ← IF FRAMEIDA THEN HIGHF ELSE FHIGH ;
01600 IF FULWIDE(ITSIX) THEN
01700 BEGIN Comment Make frame width ;
01800 OCH ← CC ; CHARCT(ITSIX) ← NCH ← FW ;
01900 COLWID(ITSIX) ← (COLWID(ITSIX) * NCH) DIV OCH ;
02000 END ;
02100 IF FULHIGH(ITSIX) THEN LINECT(ITSIX) ← FH ;
02200 L←OPEN!ACTIVE(ITSIX)←CREATE(0, AREC) ;
02300 IF NULLAREAS THEN BEGIN IDASSIGN(AREAIDA←NULLAREAS,THISAREA) ; INA←LHRH(L,INA) END ;
02400 IDASSIGN(AREAIDA ← L, THISAREA) ;
02500 DEFA ← ITSIX ; STATA ← 0 ; INA ← LHRH(0, NULLAREAS) ; NULLAREAS ← AREAIDA ;
02600 IDASSIGN("AAA←CREATE2(1, CS←COLCT(ITSIX)*2, 0, LS←LC+((LC DIV 2) MAX 8) ) ", AA) ;
02700 ZEROWORDS(CS*(LS+1), AA[1,0]) ;
02800 COMMENT FOR C ← 1 THRU CS DO FOR L ← 0 THRU LS DO AA[C,L] ← 0 ;
02900 END "MAKEAREA" ;
03000
03100 FORWARD RECURSIVE PROCEDURE ASSUREAREA ;
03200
03300 INTERNAL SIMPLE PROCEDURE SEND(INTEGER PORTIX; STRING MESSAGE) ;
03400 BEGIN "SEND"
03500 INTEGER CH ;
03600 IF 0≤ (CH ← PORCH(PORTIX)) THEN OUT(CH,MESSAGE)
03700 ELSE IF CH=-1 THEN
03800 BEGIN
03850 IF NOPGPH THEN ASSUREAREA ; TES 8/19/74 FIX BUG ;
03875 CH←FOOTSTR(IF AREAIXM THEN AREAIXM ELSE IXTEXT); TES 8/19/74 ;
03887 SSTK[CH]←SSTK[CH]&MESSAGE ;
03893 END
03900 ELSE WARN(NULL,"Can't send to a passed PORTION:"&MESSAGE) ;
04000 END "SEND" ;
04100
04200 INTERNAL RECURSIVE BOOLEAN PROCEDURE STATEMENT ;
04300 BEGIN "STATEMENT"
04400 INTEGER LVL, RLVL ; BOOLEAN VALID ;
04500 LVL ← BLNMS ; RLVL ← REPEATS ; TES 8/14/74 ;
04600 DO VALID ← CHUNK(VALID) UNTIL BLNMS≤LVL ;
04650 RETURN(RLVL>REPEATS) ; TES 8/14/74 ;
04700 END "STATEMENT" ;
00100 STRING SIMPLE PROCEDURE ALFIZE(STRING FILENAME, LEFTRIGHT) ;
00200 BEGIN "ALFIZE"
00300 INTEGER SVIHIGH, SVSHIGH, CHAN, LEFT, RIGHT, N, I ; STRING S, KEY ;
00400 SVSHED ← SHED ; SVIHIGH ← IHIGH ; SVSHIGH ← SHIGH ;
00500 IF (CHAN←GETCHAN)<0 THEN RETURN(WARN(NULL,"No Channel to Alphabetize "&FILENAME)) ;
00600 EOF ← 0 ; OPEN(CHAN, "DSK", 0, 2, IFC VERSION=ITSVER THENC 0 ELSEC 2 ENDC, 150, BRC, EOF) ;
00700 LOOKUP(CHAN, IFC TENEX THENC IFILENAME & GENEXT & ENDC FILENAME,
00800 FLAG) ; IF FLAG THEN RETURN(WARN("=","No Generated file "&FILENAME)) ;
00900 SETBREAK(LOCAL!TABLE, LEFTRIGHT&LF, NULL, "IS") ; LEFT ← LOP(LEFTRIGHT) ; RIGHT ← LOP(LEFTRIGHT) ; N ← 0 ;
01000 DO BEGIN "SENDEE"
01100 S ← INPUT(CHAN, TO!TB!FF!SKIP) ; IF EOF THEN DONE ; S ← S & TB ;
01200 DO S ← S & INPUT(CHAN, LOCAL!TABLE) UNTIL BRC=LEFT ∨ BRC=LF ∨ EOF ;
01300 IF BRC = LEFT THEN
01400 BEGIN "KEY"
01500 KEY ← NULL ; S ← S & LEFT ;
01600 DO KEY ← KEY & INPUT(CHAN, LOCAL!TABLE) UNTIL BRC=RIGHT OR BRC=LF OR EOF ;
01700 PUSHS(1,KEY) ; comment, Sort Key in SSTK ;
01800 S ← S & KEY ;
01900 IF BRC = RIGHT THEN
02000 BEGIN
02100 S ← S & RIGHT ;
02200 DO S ← S & INPUT(CHAN, LOCAL!TABLE) UNTIL BRC = LF OR EOF ;
02300 END ;
02400 END "KEY" ;
02500 PUTS(S&LF) ; comment, complete entry in STBL ;
02600 N ← N + 1 ; PUTI(1, N) ; comment, Sort Tags in ITBL ;
02700 END "SENDEE"
02800 UNTIL EOF ;
02900 QUICKERSORT(N, SVIHIGH) ;
03000 CLOSIN(CHAN) ; FILENAME ← IFC TENEX THENC
03100 IFILENAME & ALFEXT & FILENAME ELSEC
03200 FILENAME[1 TO ∞-1] & "Z" ENDC ;
03210 IFC VERSION=ITSVER THENC OPEN(CHAN, "DSK", 0, 0, 2, 150, BRC, EOF) ; ENDC
03300 ENTER(CHAN, FILENAME, FLAG) ; comment, "---.PUZ" or "---.ALF---";
03400 IF FLAG THEN RETURN(WARN(NULL,"ENTER failed for Alphabetized File "&FILENAME)) ;
03500 FOR I ← 1 THRU N DO OUT(CHAN, STBL[SVSHIGH + ITBL[SVIHIGH + I]]) ;
03600 RELEASE(CHAN) ; SHED ← SVSHED ; IHIGH ← SVIHIGH ; SHIGH ← SVSHIGH ; RETURN(FILENAME) ;
03700 END "ALFIZE" ;
03800
03900 INTERNAL SIMPLE PROCEDURE RECEIVE(INTEGER PORTIX; STRING ALPHABETIZE) ;
04000 BEGIN "RECEIVE"
04100 INTEGER CH ; STRING FIL ; LABEL TWICE ;
04200 CASE (CH ← PORCH(PORTIX)) + 6 MIN 6 OF
04300 BEGIN
04400 ie -6 ; GO TO TWICE ;
04500 ie -5 Only INSERTed ; IMPOSSIBLE("RECEIVE") ;
04600 ie -4 ; TWICE: WARN(NULL,"Already RECEIVEd generated file for this PORTION") ;
04700 ie -3 ; BEGIN "GENFILE"
04800 FIL ← PORFIL("PORSTR(PORTIX)") IFC NOT TENEX THENC & PUGEXT ENDC ;
04900 IF FULSTR(ALPHABETIZE) THEN BEGIN FIL←ALFIZE(FIL,ALPHABETIZE) ; PORCH(PORTIX)←-6 END
05000 ELSE BEGIN PORCH(PORTIX) ← -4 ; IFC TENEX THENC
05100 FIL←IFILENAME & GENEXT & FIL ENDC END ;
05200 AGENFILE ← TRUE ; SWICHF(FIL) ; PAGESCAN(LAST) ← -PAGESCAN(LAST) ;
05300 END "GENFILE" ;
05400 ie -2 Never SENT ; BEGIN END ;
05500 ie -1 ; BEGIN CH←FOOTSTR(AREAIXM); SWICH(SSTK[CH],-1,0); SSTK[CH]←NULL END ;
05600 ie 0-15 ; IMPOSSIBLE("RECEIVE") ;
05700 END ;
05800 END "RECEIVE" ;
00100 INTERNAL SIMPLE PROCEDURE PLACE(INTEGER NEWAREAIX) ;
00200 COMMENT If No Place Area, AREAIXM=0. AREAIDA≠0 if STATUS= 0 or 1 ;
00300 IF ON THEN
00400 BEGIN "PLACE"
00500 INTEGER FRM, ALLOW!FOR, MARGIX, FONTIX ;
00600 IF IXTYPE(NEWAREAIX)≠AREATYPE THEN
00700 BEGIN WARN("=","PLACE in non-area"); NEWAREAIX←IXTEXT END;
00800 IF AREAIXM THEN
00900 BEGIN TES 11/19/73 ;
01000 TFONT(AREAIXM) ← THISFONT ;
01100 OFONT(AREAIXM) ← OLDFONT ;
01200 END ;
01300 IF AREAIDA ∧ STATUS=1 THEN
01400 BEGIN
01500 COLA ← COL ; AA[COL,0] ← LHRH(COVERED,LINE) ; AA[PAL,0]←LHRH(COVERED,PINE) ; STATA←STATUS ;
01600 XGENA ← XGENLINES; RKJ;
01700 OVERA ← OVEREST ; TES 11/15/73;
01800 IF AREAIXM=NEWAREAIX THEN RETURN
01900 ELSE IF COL>COLS THEN BEGIN WARN("=","Can't PLACE inside footnotes!") ; RETURN END ;
02000 END ;
02100 IF XCRIBL AND AREAIXM NEQ NEWAREAIX THEN
02200 BEGIN INTEGER DUMMY ;TES 11/15/73 ;
02300 THISFONT ← TFONT(NEWAREAIX) ; OLDFONT ← OFONT(NEWAREAIX) ;
02400 IF (DUMMY←FONTFIL[THISFONT])>0 THEN MAKEBE(DUMMY, CW) ;
02500 END ;
02600 AREAIXM←NEWAREAIX ;
02700 IF (AREAIDA ← OPEN!ACTIVE(AREAIXM)) = 0 THEN MAKEAREA(AREAIXM)
02800 ELSE BEGIN MAKEBE(AREAIDA, THISAREA) ; IDASSIGN(AAA, AA) ; END ;
02900 IF (MARGIX ← MARGINS(AREAIXM)) = 0 THEN BEGIN LMARG ← 0 ; RMARG ← COLWID(AREAIXM) END
03000 ELSE BEGIN LMARG ← LMARGX(MARGIX) ; RMARG ← RMARGX(MARGIX) END ;
03100 ALLOW!FOR ← 2 * COLWID(AREAIXM) ;
03200 IF ALLOW!FOR > LENGTH(OWL) THEN OWL ← OWL&SPS(ALLOW!FOR - LENGTH(OWL)) ;
03300 COLS ← COLCT(AREAIXM) ; LINES ← LINECT(AREAIXM) ; STATUS ← STATA ;
03600 IF STATUS=1 THEN
03700 BEGIN "IT'S OPEN"
03800 COL ← COLA ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ; ie, Leg↔Foot;
03900 LINE ← AA[COL,0] ; COVERED ← LH(LINE) ; LINE ← RH(LINE) ; PINE ← RH("AA[PAL,0]") ;
04000 XGENLINES ← XGENA; RKJ;
04100 OVEREST ← OVERA ; TES 11/15/73 ;
04200 END "IT'S OPEN"
04300 ELSE COL←PAL←LINE←COVERED←PINE←XGENLINES←OVEREST←0 ; RKJ ADDED XGENLINES;
04400 TES ADDED OVEREST 11/15/73;
04500 END "PLACE" ;
04600
04700
04800 INTEGER PROCEDURE FIND!CHR(INTEGER CHR) ; COMMENT ADDED 2/20/73 TES ;
04900 BEGIN "FIND!CHR"
05000 INTEGER I, B ;
05100 FOR I ← LENGTH(DEFN!BRC)-LDEFN!BRC STEP -1 UNTIL 1 DO
05200 IF DEFN!BRC[I FOR 1] = CHR THEN
05300 BEGIN B ← I ; DONE END ;
05400 RETURN(B) ;
05500 END "FIND!CHR" ;
05600
05700
05800 INTERNAL SIMPLE PROCEDURE TURN(INTEGER CHR,FUN,ONOFF) ;
05900 BEGIN "TURN"
06000 INTEGER CODE, X, M, STDCHR ; BOOLEAN HADCHR, DEFD ; LABEL FIN ;
06100 DEFD ← FALSE ; CODE ← LDB(SPCODE(CHR)) ; STDCHR ← LDB(SPCHAR(FUN)) ;
06200 IF CHR=TB THEN
06300 BEGIN
06400 DPB(TABTAB ← IF ONOFF THEN FUN ELSE 0, SPCODE(CHR)) ;
06500 GO TO FIN ;
06600 END
06700 ELSE IF ¬CODE THEN HADCHR ← FALSE
06800 ELSE IF CODE=STDCHR AND ONOFF THEN GO TO FIN COMMENT ALREADY ON ;
06900 ELSE IF ¬ONOFF ∨ ¬STDCHR THEN
07000 BEGIN COMMENT REMOVE CHARACTER FROM BREAK TABLE STRING ;
07100 HADCHR ← TRUE ; X ← LENGTH(TEXT!BRC) ;
07200 START!CODE "FINDIT"
07300 LABEL NEXC, DUN ;
07400 MOVE 1, TEXT!BRC ; SKIPN 2, X ; JRST DUN ;
07500 NEXC: ILDB 3,1 ; CAMN 3, CHR ; JRST DUN ; SOJG 2, NEXC ;
07600 DUN: MOVEM 2, M ;
07700 END ;
07800 TEXT!BRC ← TEXT!BRC[1 TO X-M] & TEXT!BRC[X-M+2 TO X] ;
07900 END ;
08000 IF ONOFF THEN
08100 BEGIN "ON" COMMENT REV. 2/20/73 TES ;
08200 IF STDCHR=XCMDCHR THEN DOPASS3←TRUE; RKJ: 1-4-74;
08300 IF STDCHR ∧ STDCHR < LBRACK THEN TEXT!BRC ← TEXT!BRC & CHR ;
08400 IF FUN="{" ∧ ¬FIND!CHR(CHR) THEN
08500 BEGIN
08600 DEFN!BRC ← CHR & DEFN!BRC ;
08700 DEFD ← TRUE ;
08800 END ;
08900 DPB(STDCHR, SPCODE(CHR)) ;
09000 END "ON"
09100 ELSE BEGIN "OFF" COMMENT REV. 2/20/73 TES ;
09200 INTEGER I ;
09300 IF FUN = "{" ∧ (I ← FIND!CHR(CHR)) THEN
09400 BEGIN
09500 DEFN!BRC ← DEFN!BRC[1 TO I-1] & DEFN!BRC[I+1 TO ∞] ;
09600 DEFD ← TRUE ;
09700 END ;
09800 IF HADCHR THEN DPB(0, SPCODE(CHR)) ;
09900 END "OFF" ;
10000 SETBREAK(TEXT!TBL, TEXT!BRC&SIG!BRC, NULL, "IS") ;
10100 IF DEFD THEN SETBREAK(DEFN!TABLE, DEFN!BRC, NULL, "IS") ;
10200 FIN:
10300 IF ONOFF ≤ 0 THEN ISTK[PUSHI(TURNWDS, TURNTYPE) - 1] ←
10400 CHR LSH 7 LOR (IF CHR=TB THEN CODE ELSE CHARSP[CODE FOR 1]) ;
10500 END "TURN" ;
00100 INTERNAL RECURSIVE PROCEDURE BEGINBLOCK(BOOLEAN MIDPGPH; INTEGER ECASE ; STRING NAME) ;
00200 BEGIN "BEGINBLOCK"
00300 INTEGER MIX, I, X ;
00400 IF ECASE = 0 THEN STARTS ← STARTS + 1 comment START...END ;
00500 ELSE IF ECASE=-1 THEN ENDCASE←1 comment, ONCE merging with BEGIN ;
00600 ELSE BEGIN "NOT CLUMP"
00700 I←ENDCASE; ENDCASE←0; DBREAK; ENDCASE←I; RKJ: 7/15/74;
00750 DEPTH ← DEPTH + 1 ; MIX ← PUSHI(MODEWDS, MODETYPE) ;
00800 ARRBLT(ISTK[MIX-MODEWDS], BREAKM, MODEWDS) ;
00900 PUSHI(28, TABTYPE) ; I ← 0 ;
01000 DO ISTK[MIX←MIX+1] ← X ← TABSORT[I←I+1] UNTIL X=TWO(33) ;
01100 ISTK[MIX+1] ← ISTK[IHED] ; OLDIHED ← IHED;TES 11/15/73; IHED ← MIX + 1 ;
01200 IF MIDPGPH THEN
01300 BEGIN "SAVE FILL PARAMS"
01400 X ← MIDWDS + 1 ; PUSHI(X, MIDTYPE) ;
01500 ILBF ← CVASC(LBF) ; ARRBLT(ISTK[IHED-X], THISTYPE, X-1) ;
01600 ISTK[IHED-1]←PUSHS(1, THISWD) ; NOPGPH ← TRUE ; PLBL←BRKPLBL←-TWO(13) ;
01700 END "SAVE FILL PARAMS" ;
01800 ENDCASE ← ECASE ; STARTS ← 0 ;
01900 END "NOT CLUMP" ;
02000 IF BLNMS=MAXBLNMS THEN WARN(NULL, "Deep block nest/possibly infinite recursion");
02100 RKJ: 5-10-74 - added CAPITALIZE below ;
02200 IF NAME ≠ ALTMODE THEN BLKNAMES[BLNMS←BLNMS+1] ← CAPITALIZE(NAME) ; comment not for ONCE! ;
02300 END "BEGINBLOCK" ;
02400
02500 INTERNAL BOOLEAN SIMPLE PROCEDURE FINDINSET(INTEGER HM) ;
02600 BEGIN "FINDINSET"
02700 INTEGER ARE ;
02800 LLSCAN(LEADRESPS, NEXT!RESP, "(ARE ← CLUE(LLTHIS)) ≥ HM" ) ;
02900 RETURN(LLTHIS ∧ ARE = HM) ;
03000 END "FINDINSET" ;
03100
03200 INTERNAL INTEGER SIMPLE PROCEDURE FINDSIGNAL(INTEGER SIGASC) ;
03300 BEGIN "FINDSIGNAL"
03400 INTEGER CHR ;
03500 CHR ← SIGASC LSH -29 ;
03600 LLSCAN(SIGNALD[CHR], NEXT!RESP, "SIGASC = SIGNAL(LLTHIS)" ) ;
03700 RETURN(LLTHIS) ;
03800 END "FINDSIGNAL" ;
03900
04000 INTERNAL INTEGER SIMPLE PROCEDURE FINDTRAN(INTEGER UASYMB, VARI) ;
04100 BEGIN "FINDTRAN"
04200 LLSCAN(WAITRESP, NEXT!RESP, "CLUE(LLTHIS) = UASYMB ∧ (VARI=0 ∨ VARIETY(LLTHIS)=VARI)" ) ;
04300 RETURN(LLTHIS) ;
04400 END "FINDTRAN" ;
04500
04600 INTERNAL SIMPLE PROCEDURE COMPMAXIMS ;
04700 BEGIN "COPYMAXIMS"
04800 FMAXIM ← (RMARG-RIGHTIM)-LMARG ;
04900 NMAXIM ← COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-LMARG ;
05000 MAXIM ← IF FILL THEN FMAXIM ELSE NMAXIM ;
05100 END "COPYMAXIMS" ;
05200
05300 INTERNAL SIMPLE PROCEDURE BIND(INTEGER LOC, NEWIX) ;
05400 BEGIN "BIND"
05500 IF LOC = SYMTEXT THEN IXTEXT ← NEWIX
05600 ELSE IF LOC = SYMPAGE THEN BEGIN IXPAGE ← NEWIX ; PATPAGE ← PATT!STRS(IXPAGE) END ;
05700 DPB(NEWIX, IXN(LOC)) ; IF LDB(TYPEN(LOC)) ≥ 11 THEN DPB(LOC, BIXNUM(NEWIX)) ;
05800 END "BIND" ;
00100 INTERNAL RECURSIVE BOOLEAN PROCEDURE ENDBLOCK ;
00200 IF BLNMS<0 ∧ LAST>2 THEN BEGIN WARN("=","Extra END ignored"); BLNMS←0; RETURN(FALSE) END ELSE
00300 BEGIN "ENDBLOCK"
00400 INTEGER TYP, OLD, MIX, I, X, L1, L2, PASSED, NARROWED ; STRING S ;
00500 I←ENDCASE; ENDCASE←0; DBREAK; ENDCASE←I; RKJ: 7/11/74;
00550 NARROWED ← PASSED ← FALSE ;
00600 DO COMMENT Skip through ISTK restoring former state and terminating INDENT etc. ;
00700 BEGIN "ISTK ENTRY"
00800 TYP ← IXTYPE(IHED) ;
00900 CASE TYP - 12 OF
01000 BEGIN COMMENT BY TYPE ;
01100 [AREATYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEAREA(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01200 [UNITTYPE-12] IF ¬DISD(IHED) THEN BEGIN CLOSEUNIT(IHED,TRUE) ; NUMBER[LDB(BIXNUM(IHED))]←0 END;
01300 [MACROTYPE-12] BEGIN SSTK[BODY(IHED)]←NULL;TES 11/15/73; NUMBER[LDB(BIXNUM(IHED))] ← 0 END;
01400 [RESPTYPE-12] BEGIN "POP RESP"
01500 X ← CLUE(IHED) ; I ← VARIETY(IHED) ; OLD ← OLD!RESP(IHED) ;
01600 SSTK[BODY(IHED)] ← NULL ; TES 11/15/73 ;
01700 CASE I-1 MIN 2 OF
01800 BEGIN "BY VARIETY"
01900 ie 0 ... Phrase ;
02000 TES 11/15/73 removed this case ;
02100 ie 1 ... Inset ;
02200 IF FINDINSET(X) THEN
02300 IF ¬OLD THEN LLSKIP(LEADRESPS, NEXT!RESP)
02400 ELSE BEGIN
02500 NEXT!RESP(OLD) ← LLPOST ;
02600 IF LLPREV<0 THEN LEADRESPS←OLD ELSE NEXT!RESP(LLPREV) ← OLD ;
02700 END ;
02800 ie 2 ... Signal ;
02900 BEGIN "SIGNAL"
03000 X ← SIGNAL(IHED) ; L1 ← X LSH -29 ;
03100 IF FINDSIGNAL(X) THEN
03200 IF ¬OLD THEN BEGIN
03300 S ← NULL ;
03400 WHILE FULSTR(SIG!BRC) ∧ (L2←LOP(SIG!BRC))≠L1 DO S←S&L2;
03500 SIG!BRC ← S & SIG!BRC ;
03600 LLSKIP("SIGNALD[L1]", NEXT!RESP) ; COMMENT JAN 8 1973 ;
03700 END
03800 ELSE BEGIN
03900 NEXT!RESP(OLD) ← LLPOST ;
04000 IF LLPREV<0 THEN SIGNALD[L1]←OLD ELSE NEXT!RESP(LLPREV) ← OLD ;
04100 END ;
04200 END "SIGNAL" ;
00100 ie 3, 4 ... After, Before ;
00200 IF FINDTRAN(X,I) THEN
00300 IF ¬OLD THEN LLSKIP(WAITRESP, NEXT!RESP)
00400 ELSE BEGIN
00500 NEXT!RESP(OLD) ← LLPOST ;
00600 IF LLPREV<0 THEN WAITRESP←OLD ELSE NEXT!RESP(LLPREV) ← OLD ;
00700 END ;
00800 END "BY VARIETY" ;
00900 END "POP RESP" ;
01000 [MARGTYPE-12] IF OLD←AREAX(IHED) THEN
01100 BEGIN NARROWED ← TRUE ; MARGINS(OLD) ← X ← OLD!MARGX(IHED) ;
01200 LMARG ← IF X THEN LMARGX(X) ELSE 0 ;
01300 RMARG ← IF X THEN RMARGX(X) ELSE COLWID(OLD) ;
01400 END ;
01500 [TURNTYPE-12] IF (OLD←ISTK[IHED-1])≥0 THEN TURN(OLD LSH -7 , OLD LAND '177 , 1 ) ;
01600 [MODETYPE-12] BEGIN
01700 I ← GROUPM ; OLD ← AREAIXM ; X ← GLINEM ; TES 11/15/73 REMOVED J ← THISFONT ;
01800 ARRBLT(BREAKM, ISTK[IHED-MODEWDS], MODEWDS) ; OLD ↔ AREAIXM ;
01900 TES 11/14/73 removed IF J ≠ THISFONT THEN SELECTFONT(THISFONT);
02000 IF I THEN IF ¬GROUPM THEN DAPART
02100 ELSE IF GLINEM=0 THEN GLINEM ← X ;
02200 COMMENT ADDED THIS ↑ LINE 2/20/73 ;
02300 IF ¬PASSED ∧ NARROWED THEN NOPGPH ← 1 ;
02400 JUSTIFY ← FILL ∧ ADJUST ∨ JUSTJUST ;
02500 PLACE(IF OLD THEN OLD ELSE IXTEXT);
02600 COMPMAXIMS ;
02700 END ;
02800 [NUMTYPE-12] BEGIN
02900 OLD ← OLD!NUMBER(IHED) ;
03000 NUMBER[X ← LDB(SYMBOLWD(OLD))] ← OLD ;
03100 IF X = SYMPAGE THEN BEGIN IXPAGE ← LDB(IXN(X)) ; PATPAGE ← PATT!STRS(IXPAGE) END
03200 ELSE IF X = SYMTEXT THEN IXTEXT ← LDB(IXN(X)) ;
03300 END ;
03400 [TABTYPE-12] BEGIN
03500 MIX ← IXOLD(IHED) ; I ← 0 ;
03600 DO TABSORT[I←I+1] ← X ← ISTK[MIX←MIX+1] UNTIL X=TWO(33) ;
03700 END ;
03800 [MIDTYPE-12] BEGIN
03900 IF LENGTH(INPUTSTR)>1 THEN WARN("Imbalance","Unbalanced Response|Footnote! "&SOMEINPUT) ;
04000 THISWD←SSTK[ISTK[IHED-1]] ; OLD←PLBL ;
04100 ARRBLT(THISTYPE,ISTK[X←IXOLD(IHED)+1],IHED-X-1) ;
04200 LBF ← CVSTR(ILBF) ;
04300 WHILE FULSTR(LBF) ∧ LBF[∞ FOR 1]=0 DO LBF←LBF[1 TO ∞-1] ;
04400 IF OLD ≠ -TWO(13) THEN
04500 BEGIN COMMENT UNDEFINED PAGE LABELS -- PASS UP TO OUTER BLOCK ;
04600 X ← OLD ;
04700 DO BEGIN L1←X ; X←IF X<0 THEN NUMBER[-X] ELSE ITBL[X] END UNTIL X=-TWO(13) ;
04800 IF L1<0 THEN NUMBER[-L1] ← PLBL ELSE ITBL[L1] ← PLBL ;
04900 PLBL ← OLD ;
05000 END ;
05100 INPUTSTR←NULL ; IF THATISFULL THEN RDENTITY ELSE INPUTSTR←SWICHBACK ; PASSED←TRUE ;
05200 END ;
05300 [FONTYPE-12] IF (OLD←AREAX(IHED)) AND XCRIBL THEN TES 11/15/73 ;
05400 BEGIN
05500 FONTS(OLD) ← OUTERX(IHED) ;
05600 TFONT(OLD) ← THISFONTX(IHED) ;
05700 OFONT(OLD) ← OLDFONTX(IHED) ;
05800 IF OLD = AREAIXM THEN
05900 BEGIN
06000 THISFONT ← TFONT(OLD) ;
06100 OLDFONT ← OFONT(OLD) ;
06200 IDASSIGN("FONTFIL[THISFONT]", CW) ;
06300 END ;
06400 END ;
06500 [PITYPE-12] PICHAR[PIKEY(IHED)] ← SSTK[PIVAL(IHED)] TES 11/29/73;
06600 END ; COMMENT BY TYPE ;
06700 IHED ← IXOLD(IHED) ;
06800 END "ISTK ENTRY"
06900 UNTIL TYP=MODETYPE ∨ IHED=0 ;
07000 DEPTH ← DEPTH - 1 ;
07100 RETURN(PASSED) ;
07200 END "ENDBLOCK" ;
00100 RECURSIVE PROCEDURE TOEND ;
00200 BEGIN "TOEND"
00300 BOOLEAN VALID ;
00400 VALID ← TRUE ;
00500 DO VALID ← CHUNK(VALID) UNTIL MYEND ;
00600 MYEND ← FALSE ;
00700 END "TOEND" ;
00800
00900 INTERNAL SIMPLE PROCEDURE ANYEND(BOOLEAN CHECK) ;
01000 BEGIN "ANYEND"
01100 STRING BLOCKNAME ;
01200 BLOCKNAME ← IF BLNMS<0 THEN "!MISSING!" ELSE BLKNAMES[BLNMS] ;
01300 BLNMS ← (BLNMS MAX 0) - 1 ;
01400 IF CHECK ∧ THATISCON THEN
01500 BEGIN
01600 PASS ;
01700 LOPP(THISWD) ;
01800 RKJ: 5-10-74 - added CAPITALIZE below ;
01900 IF NOT EQU(CAPITALIZE(THISWD),BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END """&THISWD&"""") ;
02000 END
02100 ELSE IF FULSTR(BLOCKNAME) THEN WARN("Mismatched BEGIN-END","BEGIN """&BLOCKNAME&""" but END <blank>") ;
02200 END "ANYEND" ;
02300
02400 INTERNAL RECURSIVE PROCEDURE BEGINEND ;
02500 BEGIN ANYEND(TRUE) ; IF ENDBLOCK THEN WARN("=","Missed END in Response|Footnote") ELSE PASS END ;
02600
02700 INTERNAL RECURSIVE PROCEDURE ONCEEND ;
02800 IF ENDBLOCK THEN WARN("=","Missing END in Response|Footnote") ELSE BEGINEND ;
02900
03000 INTERNAL RECURSIVE PROCEDURE STARTEND ;
03100 BEGIN ANYEND(TRUE) ; STARTS ← STARTS - 1 ; PASS ; END ;
03200
03300 INTERNAL RECURSIVE PROCEDURE RESPOND(INTEGER IX) ;
03400 IF ON THEN
03500 BEGIN "RESPOND"
03600 INTEGER ARGS ; STRING COM!ENT ;
03700 ARGS ← IF VARIETY(IX) = 2 THEN NUMARGS(IX) ELSE 0 ;
03800 IF VARIETY(IX) < 3 ∧ IX ≠ SIGNALD[FF] THEN
03900 BEGIN "AT"
04000 SWICH(IF IX=SIGNALD[CR] THEN SSTK[BODY(IX)] ELSE ALTMODE&SSTK[BODY(IX)]&RCBRAK, -1, ARGS) ;
04100 RETURN ;
04200 END "AT" ;
04300 GENSYM←GENSYM+1 ; COM!ENT ← "!?@"&CVS(GENSYM) ;
04400 BEGINBLOCK( TRUE, 3 , COM!ENT ) ;
04500 SWICH(SSTK[BODY(IX)]&(CRLF&TB&TB&"END """)&COM!ENT&""";;", -1, ARGS) ;
04600 PASS ; TOEND ;
04700 END "RESPOND" ;
04800
04900 INTERNAL RECURSIVE PROCEDURE RESPEND ;
05000 BEGIN ANYEND(TRUE) ; PASS ; IF ENDBLOCK THEN MYEND←TRUE ELSE WARN("=","Extra END") ; END ;
00100 INTERNAL SIMPLE PROCEDURE OPENFRAME ;
00200 BEGIN "OPENFRAME"
00300 MAKEPAGE(FHIGH,FWIDE);
00400 OLXX ← OLMAX ; comment Total of all areas now declared ; OLX ← 0 ;
00500 IDASSIGN("OWLSF←OWLSIDA←CREATE(0,OLXX)", OWLS);
00600 IDASSIGN("MOLESF←MOLESIDA←CREATE(0,OLXX)", MOLES);
00700 IDASSIGN("SHORTF←SHORTIDA←CREATE(0,OLXX)", SHORT);
00800 END "OPENFRAME" ;
00900
01000 INTERNAL SIMPLE PROCEDURE OPENPAGE ;
01100 DO BEGIN OPENFRAME ; IDASSIGN(OLDPGIDA ← FRAMEIDA, OLDPAGE) ;
01200 PAGEVAL ← PATT!VAL(PATPAGE) ;
01300 IF FINDTRAN(SYMPAGE, 4) THEN RESPOND(LLTHIS) ;
01400 END UNTIL FRAMEIDA ;
01500
01600 SIMPLE PROCEDURE REMNULLS ;
01700 BEGIN "REMNULLS"
01800 INTEGER L, R, I ;
01900 L ← LH(INA) ; R ← RH(INA) ;
02000 IF L ∨ R THEN
02100 BEGIN
02200 I ← AREAIDA ;
02300 IF L THEN BEGIN IDASSIGN(AREAIDA←L,THISAREA); DPB(R, H2(INA)) ; END ELSE NULLAREAS ← R ;
02400 IF R THEN BEGIN IDASSIGN(AREAIDA←R,THISAREA); DPB(L, H1(INA)) ; END ;
02500 IDASSIGN(AREAIDA ← I, THISAREA) ;
02600 END
02700 ELSE NULLAREAS ← 0 ;
02800 END "REMNULLS" ;
02900
03000 INTERNAL RECURSIVE PROCEDURE OPENAREA(INTEGER ITSIX) ;
03100 BEGIN "OPENAREA"
03200 INTEGER X, PREV, NEX, C1, CC, L1, LC ;
03300 IF FRAMEIDA=0 THEN OPENPAGE ; PLACE(ITSIX) ; IF STATUS=1 THEN RETURN ; REMNULLS ;
03310 C1 ← CHAR1(ITSIX) ; CC ← CHARCT(ITSIX) ;
03320 L1 ← LINE1(ITSIX) ; LC ← LINECT(ITSIX) ;
03330 IF C1+CC-1 > WIDEF THEN
03335 WARN(NULL,"AREA " & SYM[LDB(BIXNUM(ITSIX))] & " is wider than PAGE FRAME"&CRLF&
03340 "CHARS " & CVS(C1) & " TO " & CVS(C1+CC) &
03345 " EXCEEDS " & CVS(WIDEF) & " WIDE") ;
03355 IF L1+LC-1 > HIGHF THEN
03360 WARN(NULL,"AREA " & SYM[LDB(BIXNUM(ITSIX))] & " is higher than PAGE FRAME"&CRLF&
03365 "LINES " & CVS(L1) & " TO " & CVS(L1+LC) &
03370 " EXCEEDS " & CVS(HIGHF) & " HIGH") ;
03400 INA ← FRAMEIDA ;
03500 PREV ← 0 ; NEX ← ARF ; X ← AREAIDA ; COMMENT KEEP AREAS SORTED BY LEFT EDGE ;
03600 IF C1 > 1 THEN WHILE NEX DO
03700 BEGIN
04400 IDASSIGN(AREAIDA←NEX, THISAREA) ;
04500 IF DEFA THEN IF CHAR1("DEFA") ≥ C1 THEN DONE ELSE BEGIN END
04600 ELSE BEGIN IDASSIGN(AAA,AA) ; IF AA[1,0]≥C1 THEN DONE ; END ;
04700 PREV ← AREAIDA ; NEX ← ARA ;
04800 END ;
04900 IF PREV THEN
05000 BEGIN TES AND DCS REVISED 9/24/73@SU, 10/25/73@PARC ;
05100 IDASSIGN(AREAIDA←PREV, THISAREA) ; TES ADDED THIS ;
05200 ARA ← X ;
05300 END
05400 ELSE ARF ← X ;
05500 IDASSIGN(AREAIDA←X, THISAREA) ; ARA ← NEX ;
05550 IDASSIGN(AAA, AA) ; TES 8/27/74 FIX BUG !!;
05600 STATA ← STATUS←1 ; COL ← 1 ; PAL ← COLS + 1 ;
05700 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 4) THEN RESPOND(LLTHIS) ; comment BEFORE areaname ... ;
05800 END "OPENAREA" ;
00100 INTERNAL RECURSIVE PROCEDURE CLOSET(INTEGER ITSIX; BOOLEAN CLOSEIT, DISDECLAREIT) ;
00200 BEGIN "CLOSET"
00300 IF DISDECLAREIT THEN DBREAK ;
00400 IF FINDTRAN(LDB(BIXNUM(ITSIX)), 3) THEN
00500 IF CLOSEIT ∧ ITSIX≠IXPAGE ∧ comment AFTER ;
00600 (IXTYPE(ITSIX)=AREATYPE ∨ FULSTR("CTR!VAL(""PATT!STRS(ITSIX)"")")) THEN RESPOND(LLTHIS) ;
00700 IF DISDECLAREIT THEN DISD(ITSIX) ← -1 ;
00800 END "CLOSET" ;
00900
01000 INTERNAL RECURSIVE PROCEDURE CLOSEAREA(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
01100 BEGIN "CLOSEAREA"
01200 INTEGER SAVAR, C, WC, NC, CC, LEFC ; BOOLEAN NORESP ;
01300 NORESP ← ITSIX < 0 ; ITSIX ← ABS(ITSIX) ;
01400 IF DISDECLAREIT THEN OLMAX ← OLMAX - LINECT(ITSIX)*COLCT(ITSIX) ;
01500 IF OPEN!ACTIVE(ITSIX) = 0 THEN IF DISDECLAREIT THEN CLOSET(ITSIX, FALSE, TRUE)
01600 ELSE BEGIN END
01700 ELSE BEGIN SAVAR←AREAIXM; PLACE(ITSIX); IF STATUS=0 THEN REMNULLS ; STATA ← STATUS←2;
01800 ULLA ← LINE1(ITSIX) ; AA[1,0] ← LEFC ← CHAR1(ITSIX) ;
01900 IF (NC ← COLCT(ITSIX)) > 1 THEN
02000 BEGIN
02100 WC ← COLWID(ITSIX) ; CC ← CHARCT(ITSIX) ;
02200 FOR C ← 2 THRU NC DO AA[C,0] ← LEFC + ((C-1)*(CC-WC)) DIV (NC-1) ;
02300 END ;
02400 LINECA ← LINECT(ITSIX) ; COLCA ← NC ;
02500 IF ¬NORESP THEN CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
02600 IF DISDECLAREIT THEN BEGIN STATA ← STATUS←3 ; DEFA ← 0 END ;
02700 OPEN!ACTIVE(ITSIX) ← AREAIDA ← 0 ;
02800 IF SAVAR ∧ ¬DISDECLAREIT ∧ SAVAR ≠ ITSIX THEN PLACE(SAVAR) ELSE BEGIN AREAIXM←0; STATUS←-1 END ;
02900 END ;
03000 END "CLOSEAREA" ;
03100
03200 INTERNAL RECURSIVE PROCEDURE CLOSEUNIT(INTEGER ITSIX; BOOLEAN DISDECLAREIT) ;
03300 BEGIN "CLOSEUNIT"
03400 INTEGER STRS, PP ;
03500 CLOSET(ITSIX, TRUE, DISDECLAREIT) ;
03600 IF DISDECLAREIT THEN
03700 BEGIN
03800 IF (PP ← PARENT(ITSIX)) THEN
03900 BEGIN
04000 LLSCAN("SON(PP)", BROTHER, LLTHIS=ITSIX) ;
04100 LLSKIP("SON(PP) ", BROTHER) ;
04200 END ;
04300 STRS ← PATT!STRS(ITSIX) ;
04400 PATT!VAL(STRS)←PREFIX(STRS)←INFIX(STRS)←SUFFIX(STRS)←CTR!VAL(STRS)←NULL ;
04500 IF STRS=SHED THEN SHED←SHED-5 ;
04600 END ;
04700 END "CLOSEUNIT" ;
00100 INTERNAL SIMPLE PROCEDURE DISDECLARE(INTEGER SYMB, OLDTYPE, OLDIX) ;
00200 IF ON THEN
00300 BEGIN "DISDECLARE"
00400 LABEL LOCAL; RKJ: 1-8-74;
00500 CASE OLDTYPE OF
00600 BEGIN
00700 [LOCALTYPE] LOCAL:BEGIN SSTK[OLDIX]←NULL; IF IX=SHED THEN SHED←SHED-1 END ;
00800 [INTERNTYPE] WARN("=",SYM[SYMB]&" Redeclared") ;
00900 [AREATYPE] CLOSEAREA(OLDIX,TRUE);
01000 [UNITTYPE] CLOSEUNIT(OLDIX,TRUE) ;
01100 [MACROTYPE] BEGIN OLDIX←BODY(OLDIX); GO TO LOCAL END RKJ: Delete redeclared macros 1-8-74;
01200 END ;
01300 END "DISDECLARE";
01400
01500 INTERNAL INTEGER SIMPLE PROCEDURE DECLARE(INTEGER LOC, NEWTYPE) ;
01600 IF ON THEN
01700 BEGIN "DECLARE"
01800 INTEGER NEWDEPTH, OLDDEPTH ; LABEL PURGE ;
01900 BYTEWD ← NUMBER[LOC] ;
02000 NEWDEPTH ← CASE NEWTYPE OF (0,1,DEPTH,0,DEPTH,0,0,0,0,0,1,DEPTH,DEPTH,DEPTH,DEPTH) ;
02100 IF LOC = SYMTEXT ∧ NEWTYPE ≠ AREATYPE ∨ LOC = SYMPAGE ∧ NEWTYPE ≠ UNITTYPE THEN
02200 BEGIN
02300 WARN("=",SYM[LOC] & " may only be type " & (IF LOC=SYMTEXT THEN "AREA" ELSE "UNIT")) ;
02400 GO TO PURGE ;
02500 END ;
02600 IF LDB(TYPEWD(BYTEWD)) THEN
02700 IF (OLDDEPTH ← LDB(DEPTHWD(BYTEWD))) < 1 THEN
02800 BEGIN
02900 WARN("=","You may not redeclare reserved word " & SYM[LOC]) ;
03000 PURGE: LOC ← SYMNUM("(Purged)" & SYM[LOC]) ;
03100 END
03200 ELSE IF OLDDEPTH < NEWDEPTH THEN
03300 BEGIN
03400 PUSHI(NUMWDS, NUMTYPE) ;
03500 OLD!NUMBER(IHED) ← BYTEWD ;
03600 END
03700 ELSE IF OLDDEPTH = 1 THEN
03800 BEGIN
03900 WARN("=","You may not redeclare" & SYM[LOC] & ", a global variable or PORTION") ;
04000 GO TO PURGE ;
04100 END
04200 ELSE IF OLDDEPTH=NEWDEPTH THEN
04300 DISDECLARE(LOC, LDB(TYPEWD(BYTEWD)), LDB(IXWD(BYTEWD)))
04400 ELSE WARN("=","Global " & SYM[LOC] & " redeclaring local") ;
04500 NUMBER[LOC] ← (NEWDEPTH ROT -5) LOR (LOC LSH 18) LOR (NEWTYPE LSH 14) ;
04600 RETURN(LOC) ;
04700 END "DECLARE" ;
00100 INTERNAL STRING SIMPLE PROCEDURE VASSIGN(INTEGER VSYMB, VTYPE, VIX; STRING VAL) ;
00200 BEGIN "VASSIGN" comment, NAME←VAL ;
00300 SIMPLE PROCEDURE RDONLY(STRING IV) ; WARN("=","The value of "&IV&" is read-only") ;
00400 IF ON THEN CASE VTYPE OF
00500 BEGIN COMMENT BY TYPE ;
00600 [0] BIND(VSYMB←DECLARE(VSYMB, GLOBALTYPE), PUTS(VAL)) ; ie Undeclared identifier ;
00700 [GLOBALTYPE] STBL[VIX] ← VAL ;
00800 [LOCALTYPE] SSTK[VIX] ← VAL ;
00900 [INTERNTYPE] CASE VIX OF
01000 BEGIN COMMENT INTERNAL ;
01100 ie 0 ... LINES ; RDONLY("LINES") ;
01200 ie 1 ... COLUMNS; RDONLY("COLUMNS") ;
01300 ie 2 ... ! ; ! ← VAL ;
01400 ie 3 ... SPREAD ; SPREADM ← CVD(VAL) ;
01500 ie 4 ... FILLING; RDONLY("FILLING") ;
01600 ie 5 ... !SKIP! ; MANUS!SKIP! ← CVD(VAL) ;
01700 ie 6 ... !SKIPL!; DPB(CVD(VAL), H1(MANUS!SKIP!)) ;
01800 ie 7 ... !SKIPR!; DPB(CVD(VAL), H2(MANUS!SKIP!)) ;
01900 ie 8 ... NULL ; RDONLY("NULL") ;
02000 ie 9 ... ∞ ; RDONLY("∞") ;
02100 ie 10... FOOTSEP; FOOTSEP ← VAL ;
02200 ie 11... TRUE ; RDONLY("TRUE") ;
02300 ie 12... FALSE ; RDONLY("FALSE") ;
02400 ie 13... INDENT1; FIRSTIM ← CVD(VAL) ;
02500 ie 14... INDENT2; RESTIM ← CVD(VAL) ;
02600 ie 15... INDENT3; BEGIN RIGHTIM ← CVD(VAL) ; COMPMAXIMS END ;
02700 ie 16... LMARG ; BEGIN LMARG ← CVD(VAL) MAX 0 MIN
02800 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT)-1 ; COMPMAXIMS END ;
02900 ie 17... RMARG ; BEGIN RMARG ← CVD(VAL) MAX 1 MIN
03000 COLWID(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ; COMPMAXIMS END ;
03100 ie 18... CHAR ; RDONLY("CHAR") ;
03200 ie 19... CHARS ; RDONLY("CHARS") ;
03300 ie 20... LINE ; RDONLY("LINE") ;
03400 ie 21... COLUMN ; RDONLY("COLUMN") ;
03500 ie 22... TOPLINE; RDONLY("TOPLINE") ;
03600 ie 23... XCRIBL ; RDONLY("XCRIBL") ;
03700 ie 24... CHARW ; CHARW ← CVD(VAL) ;
03800 ie 25... XGENLINES; XGENLINES ← CVD(VAL) ;
03900 ie 26... UNDERLINE ; VUNDERLINE ← VAL ; TES 10/22/73 ;
04000 ie 27... THISDEVICE ; RDONLY("DEVICE") ; TES 11/15/73
04100 ie 28... THISFONT ; RDONLY("THISFONT") ; TES 11/15/73 ;
04200 ie 29... FOOTGAP ; FOOTGAP ← CVD(VAL) ; TES 11/29/73 ;
04300 ie 30... FOOTSEPFONT ; FSFONT ← RFONT(VAL) ; TES 11/29/73 ;
04400 ie 31... TTY ; BEGIN IF NOT SWDBACK THEN OUTSTR(CRLF) ;
04500 OUTSTR(VAL & CRLF) ; SWDBACK ← TRUE ;
04600 END ; TES 11/29/73 AND 4/11/74 ;
04700 ie 32... ODDLEFTBORDER ; ODDLEFTBORDER ← CVD(VAL) ; TES 6/11/74 ;
04800 ie 33... EVENLEFTBORDER ; EVENLEFTBORDER ← CVD(VAL) ; TES 6/11/74 ;
04900 ie 34... FULLFILE ; RDONLY("FULLFILE") ; TES 6/13/74;
04905 ie 35... THISLINE ; RDONLY("THISLINE") ; TES 8/19/74 ;
04910 ie 36... MAXTEMPLATE ; MAXTEMPLATE ← CVD(VAL) ; TES 8/19/74 ;
04915 ie 37... ERRLF ; ERRLF ← CVD(VAL) ; TES 8/20/74 ;
04920 ie 38... DEBUGFLAG ; DEBUGFLAG ← CVD(VAL) ; TES 8/21/74 ;
04925 ie 39... !XGPLFTMAR ;
04930 BEGIN
04935 OUTSTR(" !XGPLFTMAR->ODD/EVENLEFTBORDER ") ;
04940 ODDLEFTBORDER ← EVENLEFTBORDER ← (CVD(VAL)*1000)/200 ;
04945 END ; TES 9/4/74 ;
05000 END ; COMMENT INTERNAL ;
05100 [MANTYPE] WARN("Improper use of `←'","← after reserved word "&SYM[VSYMB]&" -- assignment ignored") ;
05200 [PORTYPE] WARN("=","← after PORTION name "&SYM[VSYMB]) ;
05300 [PUNITTYPE] PATT!VAL("PATT!STRS(VIX)") ← VAL ;
05400 [AREATYPE] WARN("=","← after AREA name "&SYM[VSYMB]) ;
05500 [UNITTYPE] CTR!VAL("PATT!STRS(VIX)") ← VAL
05600 END ; COMMENT BY TYPE ;
05700 RETURN(VAL) ;
05800 END "VASSIGN" ;
05900
06000 INTERNAL SIMPLE PROCEDURE ASSIGN(STRING NAME, VAL) ;
06100 VASSIGN(SIMNUM(NAME), 0, SYMIX, VAL) ;
06200
06300 INTERNAL SIMPLE PROCEDURE NOPORTION ;
06400 BEGIN "NOPORTION"
06500 STRING IFIL ; INTEGER PSIX, PIX ;
06600 WARN("=","No PORTION Declaration Found") ;
06700 IFIL ← IFC NOT TENEX THENC "PUI"& ENDC CVS(INTERS←INTERS+1) ;
06800 THISPORT ← PIX ← PUTI(4, -2) ;
06900 PORSTR(PIX) ← PSIX ← PUTS(NULL) ; PUTS(NULL) ; TES 3/21/74;
07000 PORINT(PSIX) ← IFIL ; PORSEQ(SEQPORT) ← PIX ; PORSEQ(SEQPORT←PIX) ← 0 ;
07100 PORTS ← PORTS + 1 ;
07200 IFC TENEX THENC
07300 INTER ← WRITEON(TRUE, IFILENAME & OCTEXT & IFIL) ;
07400 SINTER← WRITEON(FALSE,IFILENAME & TXTEXT & IFIL) ;
07500 ELSEC
07600 INTER ← WRITEON(TRUE, IFIL & PUIEXT) ; SINTER ← WRITEON(FALSE, IFIL & "S"&PUIEXT) ;
07700 ENDC
07800 END "NOPORTION" ;
00100 STRING SIMPLE PROCEDURE CVALF(INTEGER ALFABET, VAL) ;
00200 BEGIN "CVALF" COMMENT handles 1aAiI conversions ;
00300 STRING S, A ; INTEGER I ;
00400 PRELOAD!WITH NULL, "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix",
00500 NULL, "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc",
00600 NULL, "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm" ;
00700 OWN STRING ARRAY LOWROMAN[0:2, 0:9] ;
00800 PRELOAD!WITH NULL, "I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX",
00900 NULL, "X", "XX", "XXX", "XL", "L", "LX", "LXX", "LXXX", "XC",
01000 NULL, "C", "CC", "CCC", "CD", "D", "DC", "DCC", "DCCC", "CM" ;
01100 OWN STRING ARRAY UPROMAN[0:2, 0:9] ;
01200 DEFINE BEG = "WHILE VAL DO BEGIN", OOPS = "WARN(""="",""I only know roman numerals up to 1000, sorry"")" ;
01300 IF VAL = 0 THEN RETURN("0") ;
01400 IF VAL<0 THEN BEGIN S ← "-" ; VAL ← ABS(VAL) END ELSE S ← NULL ;
01500 A ← NULL ; I ← -1 ;
01600 CASE ALFABET - 1 OF
01700 BEGIN
01800 ie 1 ... "1" ; A ← CVS(VAL) ;
01900 ie 2 ... "i" ; IF VAL < 1000 THEN BEG A ← LOWROMAN[I←I+1, VAL MOD 10]&A ;
02000 VAL← VAL DIV 10 END ELSE OOPS ;
02100 ie 3 ... "I" ; IF VAL < 1000 THEN BEG A ← UPROMAN[I←I+1, VAL MOD 10]&A ;
02200 VAL← VAL DIV 10 END ELSE OOPS ;
02300 ie 4 ... "a" ; BEG A ← ("a" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02400 ie 5 ... "A" ; BEG A ← ("A" + (VAL-1) MOD 26)&A ; VAL ← VAL DIV 26 END ;
02500 END ;
02600 RETURN(S & A) ;
02700 END "CVALF" ;
02800
02900 INTEGER SIMPLE PROCEDURE CHRSALF(INTEGER INT, ALFABET) ;
03000 BEGIN "CHRSALF"
03100 INTEGER LABS, LSIGN ; STRING STR ; PRELOAD!WITH [2]3,2,[5]1,[2]0 ; OWN INTEGER ARRAY L[0:9] ;
03200 LSIGN ← IF INT < 0 THEN 1 ELSE 0 ; INT ← ABS(INT) ; STR ← CVS(INT) ;
03300 CASE ALFABET DIV 2 OF
03400 BEGIN
03500 ie 1 ... "1" ; LABS ← LENGTH(STR) ;
03600 ie 2 ... i,I ; LABS ← 4*LENGTH(STR) - L[STR-"0"] ; comment, Believe-it-or-Not ;
03700 ie 3 ... a,A ; LABS ← LENGTH(CVALF(ALFABET, INT)) ;
03800 END ;
03900 RETURN(LABS + LSIGN) ;
04000 END "CHRSALF" ;
04100
04200 SIMPLE PROCEDURE FIXFRAME(INTEGER FRIDA) ;
04300 BEGIN "FIXFRAME"
04400 IF AREAIDA ∧ STATUS=1 THEN PLACE(AREAIXM) ; COMMENT BE SURE LINE,PINE STORED IN AA ;
04500 IF MOLESIDA THEN MOLES[0] ← OLX ; TES 1/15/74 ADDED IF.. ;
04600 IDASSIGN(FRAMEIDA ← FRIDA, THISFRAME) ;
04700 IDASSIGN("OWLSIDA ← OWLSF", OWLS) ;
04800 IDASSIGN("MOLESIDA ← MOLESF", MOLES) ;
04900 IDASSIGN("SHORTIDA ← SHORTF", SHORT) ;
05000 OLX ← MOLES[0] ; AREAIDA ← 0 ;
05100 END "FIXFRAME" ;
05200
05300 INTERNAL INTEGER SIMPLE PROCEDURE NEWBLANK(INTEGER MOLE) ;
05400 BEGIN MOLES[OLX←OLX+1]←MOLE ; OWLS[OLX]←0 ; RETURN(OLX); END "NEWBLANK";
05500
05600 INTEGER SIMPLE PROCEDURE NEWNEWBLANK(INTEGER NMOLE) ; TES 1/16/74;
05700 BEGIN NMOLES[NOLX←NOLX+1]←NMOLE ; NOWLS[NOLX]←0 ; RETURN(NOLX); END "NEWNEWBLANK";
05800
05900 SIMPLE INTEGER PROCEDURE TOPMOST(INTEGER COLNO, LINO) ;
06000 BEGIN TES 12/6/73 USED BY PLACELINE FOR GLINEM IN FOOT ;
06100 WHILE LINO>1 AND (LDB(ABOVEM("AA[COLNO,LINO]")) OR LDB(BELOWM("AA[COL,LINO-1]"))) DO
06200 LINO ← LINO - 1 ;
06300 RETURN(AA[COLNO,LINO]) ;
06400 END "TOPMOST" ;
06500
06600 SIMPLE STRING PROCEDURE ENOUGH(STRING STR ; INTEGER WID, F) ;
06700 BEGIN TES 11/29/73 enough of STR to extend WID charws in font F ;
06800 INTEGER WASF, N, X ; STRING S2 ;
06900 WASF ← THISFONT ; S2 ← STR ;
07000 IDASSIGN("FONTFIL[F]", CW) ; X ← WID * CHARW ; N ← 0 ;
07100 WHILE FULSTR(S2) AND X GEQ 0 DO
07200 BEGIN N←N+1 ; X ← X-CW[LOP(S2)] END ;
07300 IF X<0 THEN N ← N-1 ;
07400 IDASSIGN("FONTFIL[WASF]", CW) ;
07500 RETURN(STR[1 TO N]) ;
07600 END ;
00100 INTERNAL PROCEDURE FINPAGE ;
00200 BEGIN "FINPAGE" COMMENT ***T EMPO RA RY V ERS I ON -- No Boxes **** ;
00300 INTEGER A, CS, LS, C, L, X, LB, LBPAGE, LINK, LINENO, FOOTLINE1, F, OWLINE, ARIX ;
00400 INTEGER NULINE, NUPINE, NUINE, NLFOOT, NPFOOT, NFOOT, NAREA ;
00500 IF EXNEXTPAGE THEN BEGIN WARN("=","Response to PAGE change called NEXT PAGE again.") ; RETURN END ;
00600 EXNEXTPAGE ← TRUE ;
00700 BEGIN "PAGEOUT"
00800 COMMENT PASS 1 OUTPUT FORMAT FOR EACH PAGE :
00900 Height Width XGPLeftMargin
01000 For each area:
01100 UpperLine NumCols NumLines
01200 For each column:
01300 LeftChar
01400 For each non-null line: LineNo SHORTM Index of PUInS.PUI line
01500 0
01600 -10
01700 ;
01800 IF OLDPGIDA ≠ FRAMEIDA THEN BEGIN WARN("=","FRAME≠PAGE at end of page"); FIXFRAME(OLDPGIDA) END ;
01900 IF AREAIDA ∧ AREAIXM ∧ STATUS=1 THEN CLOSEAREA(AREAIXM, FALSE) ;
02000 IF (A ← ARF) THEN
02100 BEGIN "NONEMPTY"
02200 INTEGER ARRAY XTRALINES[1:HIGHF]; RKJ TO FIXUP "TOPLINES" OF AREAS;
02300 IF INTER ≤ 0 THEN NOPORTION ;
02400 LS←0;
02500 WHILE A DO BEGIN "COLLECTXGENS"
02600 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
02700 IF STATA THEN LS ← LS + (XTRALINES[ULLA MAX 1] ← XGENA);
02800 END "COLLECTXGENS";
02900 A←ARF;
03000 WORDOUT(INTER, HIGHF+LS) ; WORDOUT(INTER, WIDEF) ;
03100 WORDOUT(INTER, IF NULSTR("S←CTR!VAL(PATPAGE)") OR CVD(S) MOD 2 THEN
03200 ODDLEFTBORDER ELSE EVENLEFTBORDER) ; TES 6/11/74 ;
03300 WHILE A DO BEGIN "AFTER AREA RESPONSES"
03400 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
03500 IF (X ← DEFA) ∧ STATA=1 ∧ FINDTRAN(LDB(BIXNUM(X)), 3) THEN RESPOND(LLTHIS) ;
03600 END "AFTER AREA RESPONSES" ;
03700 A ← ARF ;
03800 WHILE A DO BEGIN "CLOSE ALL AREAS"
03900 IDASSIGN(AREAIDA←A, THISAREA) ; A ← ARA ; IDASSIGN(AAA, AA) ;
04000 IF STATA = 1 THEN CLOSEAREA(-DEFA, FALSE) ;
04100 END "CLOSE ALL AREAS" ;
04200 A ← ARF ;
04300 WHILE A DO
04400 BEGIN "AREAOUT"
04500 IDASSIGN(AREAIDA←A, THISAREA) ; NAREA ← 0 ; IDASSIGN(AAA, AA) ;
00100 IF STATA > 1 THEN
00200 BEGIN "AREAUSED" TES CHANGED X TO ARIX 12/5/73 ;
00300 IF GRPOLX ∧ (STATUS←STATA)=2 ∧ (ARIX ← DEFA) THEN
00400 BEGIN COMMENT SET UP GROUP OVERFLOW INFO ;
00500 FIXFRAME(NEWPGIDA) ; OPENAREA(ARIX) ; NAREA ← AREAIDA ;
00600 IDASSIGN(AAA, NAA) ; NLFOOT←NPFOOT←NULINE←NUPINE←0 ;
00700 FIXFRAME(OLDPGIDA) ; IDASSIGN(AREAIDA←A, THISAREA) ;
00800 IDASSIGN(AAA, AA) ;
00900 END ;
01000 CS ← COLCA ; LS ← LINECA + XGENA ; RKJ ADDED XGENA;
01100 F←0; RKJ;
01200 FOR C←1 THRU ULLA-1 DO F←F+XTRALINES[C]; RKJ SEE IF ANY AREAS ABOVE THIS ONE HAVE "XTRALINES";
01300 WORDOUT(INTER, ULLA+F) ; RKJ ADDED F; WORDOUT(INTER, CS) ; WORDOUT(INTER, LS) ;
01400 FOR C ← 1 THRU CS DO
01500 BEGIN "AREACOL" WORDOUT(INTER, AA[C,0]) ; FOOTLINE1 ← LS - RH("AA[CS+C,0]") ;
01600 FOR F ← 0, CS DO FOR L ← 1 THRU LS DO IF (X ← AA[F+C, L]) THEN
01700 IF GRPOLX = 0 ∨ X < GRPOLX ∨ X > GRPTOP THEN
01800 BEGIN "AREALINE" LINENO ← IF F=0 THEN L ELSE FOOTLINE1 + L ;
01900 IF (LB ← LDB(LABELM(X))) THEN
02000 BEGIN "A PAGE LABEL"
02100 LBPAGE ← 2 ROT -2 LOR PUTS(PAGEVAL&
02150 (IF XCRIBL THEN ALTMODE&CVS(XLENGTH(PAGEVAL)) ELSE NULL)) ;
02200 WHILE LB ≠ -TWO(13) DO
02300 IF (LINK ← LB) < 0 THEN
02400 BEGIN
02500 LB←NUMBER[-LINK] ;
02600 NUMBER[-LINK] ← LBPAGE ;
02700 END
02800 ELSE BEGIN LB←ITBL[LINK] ; ITBL[LINK]←LBPAGE END ;
02900 END "A PAGE LABEL" ;
03000 IF OWLINE ← OWLS[X] THEN BEGIN WORDOUT(INTER, LINENO) ;
03100 WORDOUT(INTER, SHORT[X]) ; WORDOUT(INTER, OWLINE) END ;
03200 END "AREALINE"
03300 ELSE BEGIN "GRP OVERFLOW"
03400 IF F AND NUPINE=0 AND GRPOLX>AA[F+C,1] THEN TES 11/5,12/11/73 ;
03500 BEGIN "FOOTSP"
03600 FOR NUPINE←1 THRU FOOTGAP DO
03700 NAA[F+1,NUPINE] ←
03800 TES 1/16/74 NEWNEW: ;
03900 NEWNEWBLANK(IF NUPINE=1 THEN BLW ELSE ABV!BLW) ;
04000 NAA[F+1,NUPINE]←NOLX←NOLX+1 ;
04100 NOWLS[NOLX] ← OWLSEQ ← OWLSEQ+1 ;
04200 IF XCRIBL THEN
04300 OUT(SINTER,CVSR(OWLSEQ)&ALTMODE&
04400 PICKFONT(FSFONT)&ENOUGH(FOOTSEP,COLWID(AREAIXM),FSFONT)&CRLF)
04500 ELSE
04600 OUT(SINTER, CVSR(OWLSEQ) & ALTMODE &
04700 FOOTSEP[1 TO COLWID(ARIX)] & CRLF) ;
04800 NMOLES[NOLX] ← IF FOOTGAP=0 THEN BLW ELSE ABV!BLW ;
04900 END "FOOTSP" ;
05000 NUINE ← IF F THEN NUPINE ← NUPINE + 1 ELSE NULINE ← NULINE + 1 ;
05100 NFOOT ← IF LDB(FOOTM(X)) = 0 THEN 0
05200 ELSE IF F THEN NPFOOT←NPFOOT+1 ELSE NLFOOT←NLFOOT+1 ;
05300 NAA[F+1, NUINE] ← NOLX ← NOLX + 1 ; NOWLS[NOLX] ← OWLS[X] ;
05400 IF NFOOT THEN DPB(NFOOT, FOOTM(X)) ; NMOLES[NOLX] ← MOLES[X] ;
05500 NSHORT[NOLX] ← SHORT[X] ;
05600 END "GRP OVERFLOW" ;
05700 WORDOUT(INTER, 0) ;
05800 END "AREACOL" ;
05900 END "AREAUSED" ;
06000 A ← ARA ;
06100 GOAWAY(WHATIS(AA)) ; GOAWAY(AREAIDA) ;
06200 IF NAREA THEN
06300 BEGIN
06400 NAA[1, 0] ← NULINE ; NAA[CS+1, 0] ← NUPINE ;
06500 IDASSIGN(AREAIDA←NAREA, THISAREA) ; COLA ← 1 ; AREAIDA ← 0 ;
06600 END ;
06700 END "AREAOUT" ;
06800 WORDOUT(INTER, -10) ;
06900 END "NONEMPTY" ;
07000 GOAWAY(MOLESIDA) ; GOAWAY(SHORTIDA) ; GOAWAY(-1 LSH 18 + OWLSIDA) ;
07100 MOLESIDA ← SHORTIDA ← OWLSIDA ← GROUPM ← GLINEM ← 0 ;
07200 GOAWAY(FRAMEIDA) ; FRAMEIDA ← OLDPGIDA ← AREAIDA ← 0 ; STATUS ← -1 ;
07300 END "PAGEOUT" ;
07400 IF GRPOLX THEN GRPOLX ← 0 ;
07500 EXNEXTPAGE ← FALSE ;
07600 OVEREST ← 0; comment short font kludge ;
07700 END "FINPAGE" ;
00100 INTERNAL RECURSIVE PROCEDURE USTEP(INTEGER USYMB, UIX) ;
00200 BEGIN "USTEP"
00300 INTEGER PS, PARIX, PARTYPE, SONIX, SONPS, IVAL, SVTY, SVIX, SVSY, SVTHAT ;
00400 INTEGER I;
00500 STRING PARVAL, CVAL, PVAL, SVWD ;
00600 IF UIX>0 ∧ ¬IN!LINE(UIX) THEN DBREAK ;
00700 IF UIX>0 ∧ FULSTR("CTR!VAL(""PATT!STRS(UIX)"")") ∧ FINDTRAN(USYMB, 3) THEN RESPOND(LLTHIS) ;
00800 IF UIX = IXPAGE AND OLDPGIDA THEN FINPAGE ELSE UIX ← ABS(UIX) ;
00900 PS ← PATT!STRS(UIX) ; CVAL ← CTR!VAL(PS) ;
01000 CTR!VAL(PS) ← CVAL ←
01100 CVS(IVAL←IF NULSTR(CVAL) THEN CTR!INIT(UIX)-TWO(14) ELSE CVD(CVAL)+CTR!STEP(UIX)-TWO(6)) ;
01200 PARVAL ← IF PATT!PARENT(UIX) ∧ (PARIX ← PARENT(UIX)) THEN
01300 EVALV("(a parent unit)", PARIX, PUNITTYPE) ELSE NULL ;
01400 IF PATT!ALF(UIX) THEN
01500 PVAL ← ! ← PREFIX(PS)&PARVAL&INFIX(PS)&CVALF(PATT!ALF(UIX),IVAL)&SUFFIX(PS)
01600 ELSE BEGIN
01700 SVTY←THISTYPE ; SVIX←IX ; SVSY←SYMB ; SVWD←THISWD ; SVTHAT←THATISFULL ;
01800 SWICH(PREFIX(PS), -1, 0) ; PASS ; PVAL ← E(NULL, NULL) ;
01900 PASS ; IF ITS(;) THEN PASS ;
02000 IF ¬ITS(!!!) THEN WARN("=","Unbalanced COUNT Template") ;
02100 SWICHBACK ;
02200 THISTYPE←SVTY ; IX←SVIX ; SYMB←SVSY ; THISWD←SVWD ;
02300 IF SVTHAT THEN RDENTITY ELSE EMPTYTHAT;
02400 END ;
02500 IF LENGTH(CVAL) > CTR!CHRS(UIX) THEN
02600 BEGIN
02700 WARN("Counter underestimated","Underestimated counter "&SYM[USYMB]&" -- reached "&CVAL) ;
02800 CTR!CHRS(UIX) ← LENGTH(CVAL) ;
02900 END ;
03000 IF LENGTH(PVAL) > PATT!CHRS(UIX) THEN
03100 BEGIN
03200 IF PATT!STRS(UIX) THEN WARN("Pattern underestimate",
03300 "Underestimated unit "&SYM[USYMB]&": -- reached "&PVAL) ;
03400 PATT!CHRS(UIX) ← LENGTH(PVAL) ;
03500 END ;
03600 PATT!VAL(PS) ← PVAL ; SONIX ← SON(UIX) ;
03700 WHILE SONIX > 0 DO
03800 BEGIN
03900 SONPS ← PATT!STRS(SONIX) ;
04000 IF SONIX≠IXPAGE ∧ FULSTR("CTR!VAL(SONPS)") ∧ FINDTRAN(LDB(BIXNUM(SONIX)),3) THEN RESPOND(LLTHIS) ;
04100 CTR!VAL(SONPS) ← PATT!VAL(SONPS) ← NULL ;
04200 IF SONIX = IXPAGE THEN USTEP(SYMPAGE, SONIX ← -SONIX) ;
04300 DO SONIX ← IF SONIX>0 ∧ (K←SON(SONIX)) THEN K ELSE IF (K←BROTHER(ABS SONIX)) THEN K
04400 ELSE -PARENT(ABS SONIX) UNTIL SONIX>0 ∨ SONIX=-UIX ;
04500 END ;
04600 IF UIX ≠ IXPAGE ∧ FINDTRAN(USYMB, 4) THEN RESPOND(LLTHIS) ;
04700 IF UIX = IXPAGE THEN PAGEVAL ← PATT!VAL(PATPAGE) ;
04800 ! ← PVAL ; C! ← CVAL ; comment RESPOND or USTEP(..PAGE..) might have changed it ;
04900 END "USTEP" ;
05000
05100 INTERNAL SIMPLE PROCEDURE NEXTPAGE ;
05200 BEGIN
05300 INTEGER SAVEAREA ;
05400 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
05500 USTEP(SYMPAGE, IXPAGE) ;
05600 PLACE(LDB(IXN(SAVEAREA))) ;
05700 END ;
05800
05900 SIMPLE PROCEDURE OWT(STRING C) ;
06000 BEGIN "OWT"
06100 IF NULSTR(C) THEN BEGIN OWLS[OLX] ← 0 ; RETURN END ;
06200 IF INTER ≤ 0 THEN NOPORTION ;
06300 OWLS[OLX] ← OWLSEQ ← OWLSEQ + 1 ;
06400 OUT(SINTER, CVSR(OWLSEQ) & C) ;
06500 END "OWT" ;
00100 INTERNAL PROCEDURE CREUNIT(INTEGER INLINE, PFROM, PTO, PBY, PIN;
00200 STRING PPRINTING; INTEGER USYMB) ;
00300 BEGIN "CREUNIT"
00400 INTEGER TEMP, LENPAT, PARENTCHARS, POSNALF, POSN!, PS, ALF, UIX, PINIX, PINPS, PCHARS ;
00500 STRING S!, SPAR, SPAR! ;
00600 USYMB ← DECLARE(USYMB, UNITTYPE) ; TEMP ← DECLARE(SYMNUM(SYM[USYMB]&"!"), PUNITTYPE) ;
00700 UIX ← PUSHI(UNITWDS, UNITTYPE) ; PS ← PUSHS(5, NULL) ; PATT!STRS(UIX) ← PS ;
00800 BIND(USYMB, UIX) ; DPB(UIX, IXN(TEMP)) ;
00900 CTR!INIT(UIX) ← PFROM + TWO(14) ; CTR!STEP(UIX) ← PBY + TWO(6) ;
01000 TES 10/25/73 ; IN!LINE(UIX) ← IF UIX=IXPAGE THEN 0 ELSE INLINE ;
01100 PINIX ← IF PIN THEN LDB(IXN(PIN)) ELSE 0 ; PARENT(UIX) ← PINIX ;
01200 IF PIN = 0 THEN PARENTCHARS ← PINPS ← 0
01300 ELSE IF LDB(TYPEN(PIN)) = UNITTYPE THEN
01400 BEGIN
01500 PARENTCHARS ← PATT!CHRS(PINIX) ; PINPS ← PATT!STRS(PINIX) ;
01600 BROTHER(UIX) ← SON(PINIX) ; SON(PINIX) ← UIX ;
01700 END
01800 ELSE BEGIN WARN("=","Undeclared Parent Unit "&SYMB) ; PINPS ← 0 ; PARENTCHARS ← 2 END ;
01900 PCHARS ← LENGTH(CVS(PFROM)) MAX LENGTH(CVS(PTO)) ;
02000 IF FULSTR(PPRINTING) ∧ PPRINTING=0 THEN
02100 BEGIN "TEMPLATE"
02200 PREFIX(PS) ← "!←" & PPRINTING[2 TO ∞] & ";!!!;;" ;
02300 PATT!ALF(UIX) ← 0 ;
02400 IF PIN≠0 ∧ PINPS=0 THEN TEMP ← PCHARS + PARENTCHARS comment lousy guess ;
02500 ELSE BEGIN
02600 S! ← ! ; CTR!VAL(PS) ← CVS(PTO - PBY) ; CTR!CHRS(UIX)←PATT!CHRS(UIX)←1000 ;
02700 IF PINPS THEN BEGIN SPAR ← CTR!VAL(PINPS) ; SPAR! ← PATT!VAL(PINPS) ;
02800 CTR!VAL(PINPS) ← "999999"[1 TO CTR!CHRS(PINIX)] ;
02900 PATT!VAL(PINPS) ← ! ← "9999999999999999"[1 TO PARENTCHARS] ; END ;
03000 USTEP(USYMB, -UIX) ; TEMP ← LENGTH(!) ;
03100 ! ← S! ; IF PINPS THEN BEGIN CTR!VAL(PINPS) ← SPAR ; PATT!VAL(PINPS) ← SPAR! END ;
03200 END ;
03300 END "TEMPLATE"
03400 ELSE BEGIN "PATTERN"
03500 STRING PATCOPY ; LABEL FALF ; INTEGER ARRAY PCH[1:LENGTH(PPRINTING)] ;
03600 PRELOAD!WITH "1", "i", "I", "a", "A" ; OWN INTEGER ARRAY ALFS[1:5] ;
03700 PATCOPY ← PPRINTING ; LENPAT ← 0 ; WHILE FULSTR(PATCOPY) DO PCH[LENPAT←LENPAT+1]←LOP(PATCOPY) ;
03800 FOR POSNALF ← LENPAT DOWN 1 DO FOR ALF ← 1 THRU 5 DO IF ALFS[ALF]=PCH[POSNALF] THEN GO TO FALF;
03900 WARN("=","No 1, i, I, a, or A in pattern for "&SYM[SYMB]) ;
04000 POSNALF ← LENPAT + 1 ; PPRINTING ← PPRINTING & "1" ;
04100 FALF: POSN! ← POSNALF - 1 ; WHILE POSN! ∧ PCH[POSN!]≠"!" DO POSN! ← POSN! - 1 ;
04200 PATT!ALF(UIX) ← ALF ; PATT!PARENT(UIX) ← IF POSN! THEN 1 ELSE 0 ;
04300 PREFIX(PS) ← PPRINTING[1 TO POSN!-1] ; INFIX(PS) ← PPRINTING[POSN!+1 TO POSNALF-1] ;
04400 SUFFIX(PS) ← PPRINTING[POSNALF+1 TO ∞] ; PATT!VAL(PS) ← NULL ;
04500 TEMP ← LENGTH(PREFIX(PS)) + PARENTCHARS + LENGTH(INFIX(PS)) +
04600 (CHRSALF(PFROM,ALF) MAX CHRSALF(PTO,ALF)) + LENGTH(SUFFIX(PS));
04700 END "PATTERN" ;
04800 PATT!CHRS(UIX) ← TEMP ; CTR!CHRS(UIX) ← PCHARS ; PATT!VAL(PS)←CTR!VAL(PS)←NULL ;
04900 END "CREUNIT" ;
00100 RECURSIVE PROCEDURE ASSUREAREA ;
00200 IF AREAIDA = 0 ∨ STATUS ≠ 1 THEN OPENAREA(IF AREAIXM THEN AREAIXM ELSE IXTEXT) ;
00300
00400 RECURSIVE BOOLEAN PROCEDURE MOVEGROUP(BOOLEAN OFFPAGE ; INTEGER TOCOL, TOLINE, EXTRA) ;
00500 BEGIN "MOVEGROUP"
00600 INTEGER SAVEAREA, LFOOT, PFOOT, FOOL, C, L, L1, L2, F, TC, TL, X ;
00700 IF ¬OFFPAGE THEN
00800 IF COL≤COLS<TOCOL ∨ TOCOL>2*COLS THEN BEGIN OFFPAGE←TRUE ; TOCOL ← IF COL>COLS THEN COLS+1 ELSE 1 END ;
00900 IF OFFPAGE THEN
01000 BEGIN "OTHER PAGE"
01100 SAVEAREA ← IF AREAIXM THEN LDB(BIXNUM(AREAIXM)) ELSE SYMTEXT ;
01200 GRPTOP ← OLX ; GRPOLX ← GLINEM ; GLINEM ← 0 ; CLOSEAREA(AREAIXM, FALSE) ;
01300 MOLES[0]←OLX ; OPENFRAME ; IDASSIGN(NEWPGIDA←FRAMEIDA, NEWPAGE) ;
01400 IDASSIGN("MOLESF", NMOLES) ; IDASSIGN("SHORTF", NSHORT) ; SIDASSIGN("OWLSF", NOWLS) ;
01500 NOLX ← 0 ; TES 1/15/74 0 WAS OLX ; FIXFRAME(OLDPGIDA) ;
01600 USTEP(SYMPAGE,IXPAGE) ; NMOLES[0]←NOLX ; NSHORT[0]←NOLX ;
01700 FIXFRAME(NEWPGIDA) ; IDASSIGN(OLDPGIDA←NEWPGIDA, OLDPAGE) ;
01800 F ← ARF ;
01900 WHILE F DO
02000 BEGIN
02100 IDASSIGN(AREAIDA←F, THISAREA) ; F ← ARA ;
02200 IF (X ← DEFA) THEN
02300 BEGIN OLD!ACTIVE(X)←NEW!ACTIVE(X); NEW!ACTIVE(X)←0 END ;
02400 END ;
02500 NEWPGIDA ← 0 ; OPENAREA(LDB(IXN(SAVEAREA))) ;
02600 IF FINDTRAN(SYMPAGE,4) THEN RESPOND(LLTHIS) ;
02700 IF TOCOL > COLS THEN BEGIN COL ↔ PAL ; LINE ↔ PINE END ;
02800 END "OTHER PAGE"
02900 ELSE BEGIN "SAME PAGE"
03000 GRPOLX ← GLINEM ; LFOOT ← 0 ; FOOL ← IF PAL>COL THEN PINE ELSE LINE ;
03100 PFOOT ← IF FOOL=0 THEN 0 ELSE IF LDB(FOOTM("AA[PAL MAX COL,FOOL]"))=31 THEN 30 ELSE 0;
03200 FOR C ← COL, PAL DO
03300 BEGIN
03400 L1 ← 1 ; L2 ← IF C = COL THEN LINE ELSE PINE ;
03500 TC ← IF C=COL THEN TOCOL ELSE (TOCOL+COLS-1) MOD (2*COLS) + 1 ;
03600 TL ← IF C=COL THEN TOLINE-1 ELSE RH("AA[TC,0]") ;
03700 F ← IF C ≤ COLS THEN LFOOT ELSE PFOOT ;
03800 FOR L ← L1 THRU L2 DO IF (X ← AA[C,L]) ≥ GRPOLX THEN
03900 BEGIN
04000 AA[TC, TL ← TL + 1] ← X ; AA[C, L] ← 0 ;
04100 IF LDB(FOOTM(X)) THEN DPB(F←IF F=31 THEN 1 ELSE F+1, FOOTM(X)) ;
04200 END ;
04300 IF C= COL THEN BEGIN LINE ← TL ; COL ← TC END ELSE BEGIN PINE ← TL ; PAL ← TC END ;
04400 END ;
04500 GRPOLX ← 0 ;
04600 END "SAME PAGE" ;
04700 DAPART ; RETURN(TRUE) ;
04800 END "MOVEGROUP" ;
00100 INTERNAL RECURSIVE INTEGER PROCEDURE FIND!ROOM(INTEGER SOURCE,
00200 EXTRA, FROMCOL, FROMLINE, MORECOMING) ;
00300 BEGIN "FIND!ROOM"
00400 INTEGER WANT, LEAD, I, C, L, SAVEAREA, KOLS ; LABEL FOUND, TRYHERE ;
00500 ASSUREAREA ;
00600 IF SOURCE≤0 THEN BEGIN WANT←EXTRA ; LEAD←-SOURCE END ELSE BEGIN WANT←1; LEAD←0 END;
00700 IF WANT > LINES THEN TES 12/6/73 LENGTHENED MESSAGE ;
00800 BEGIN WARN("Can't fit here",
00900 "This line (with its PREFACE,SPREAD,SOMESCRIPTS) needs " &
01000 CVS(WANT) & " lines of paper,
01100 but AREA " & SYM[LDB(BIXNUM(AREAIXM))] &
01200 " is declared only " & CVS(LINES) & " lines HIGH");
01300 RETURN(FALSE) ;
01400 END;
01500 KOLS ← IF FROMCOL > COLS THEN 2*COLS ELSE COLS ;
01600 TRYHERE:
01700 FOR C ← FROMCOL THRU KOLS DO
01800 IF (LINES-MORECOMING) - (L← IF C=FROMCOL THEN FROMLINE ELSE 0) + XGENLINES - PINE ≥
01900 (IF L THEN WANT+LEAD ELSE WANT) THEN GO TO FOUND ;
02000 IF GLINEM ∧ C≠FROMCOL ∧ MOVEGROUP(TRUE, KOLS+1-COLS,0,EXTRA) THEN
02100 BEGIN C←COL; L←LINE; GO FOUND END ;
02200 IF TEXTAR(AREAIXM) THEN
02300 BEGIN
02400 NEXTPAGE ; OPENAREA(AREAIXM) ;
02500 IF FROMCOL>COLS ∧ COL≤COLS ∨ FROMCOL≤COLS ∧ COL>COLS THEN
02600 BEGIN
02700 TES 12/6/73 DELETED: IF FROMCOL>COLS THEN FOOTTOP ← 1 ; COMMENT ADDED BY RKJ ;
02800 PAL ↔ COL ; LINE ↔ PINE ;
02900 END ;
03000 FROMCOL ← COL ; FROMLINE ← LINE; GO TO TRYHERE ;
03100 END
03200 ELSE BEGIN TES 12/6/73 LENGTHENED MESSAGE ;
03300 WARN("TITLE AREA overflow","Overflowed title area " & SYM[LDB(BIXNUM(AREAIXM))]) ;
03400 FOR C ← 1 THRU COLS DO AA[C, 0] ← AA[COLS+C,0] ← 0 ;
03500 PAL ← (C ← COL ← 1) + COLS ; L ← 0 ;
03600 END ;
03700 FOUND:
03800 IF C=COL THEN LINE←L
03900 ELSE IF GLINEM ∧ MOVEGROUP(FALSE, C, L, EXTRA) THEN BEGIN L ← LINE ; C ← COL END
04000 ELSE BEGIN
04100 COL ← C ; PAL ← (COL+COLS-1) MOD (2*COLS) + 1 ;
04200 LINE ← L ; PINE ← RH("AA[PAL,0]") ;
04300 END ;
04400 IF OLX+WANT+LEAD > OLXX THEN GROWOWLS(WANT+LEAD+25) ;
04500 IF LINE AND LEAD THEN
04600 BEGIN
04700 FOR I ← 1 THRU LEAD DO AA[COL, LINE+I] ← NEWBLANK(IF GROUPM ∨ I>1 THEN ABV!BLW ELSE BLW) ;
04800 LINE ← LINE + LEAD ;
04900 END ;
05000 RETURN(L+1) ;
05100 END "FIND!ROOM" ;
05200
05300 INTERNAL RECURSIVE PROCEDURE TOCOLUMN(INTEGER COLNO) ; IF ON THEN
05400 BEGIN "TOCOLUMN"
05500 ASSUREAREA ;
05600 IF COLNO < COL ∨ (COLNO=COL ∧ LINE) OR TES 10/25/73; COLNO>COLS THEN NEXTPAGE ;
05700 IF 1≤COLNO≤COLS THEN COL←COLNO ELSE
05800 BEGIN TES 10/25/73;
05900 WARN(NULL, "SKIP to nonexistent column "&CVS(COLNO));
06000 COLNO ← 1 ;
06100 END ;
06200 LINE ← 0 ; IF COL>1 THEN OPENAREA(AREAIXM) ;
06300 END "TOCOLUMN" ;
06400
06500 INTERNAL RECURSIVE PROCEDURE TOLINE(INTEGER LINENO) ; IF ON THEN
06600 BEGIN "TOLINE"
06700 ASSUREAREA ;
06800 IF LINENO < LINE THEN
06900 IF COL = COLS THEN
07000 BEGIN NEXTPAGE ; IF LINENO>1 THEN OPENAREA(AREAIXM) END
07100 ELSE BEGIN COL ← COL+1 ; LINE ← 0 ; END ;
07200 IF LINENO=1 THEN LINE←1 ELSE FIND!ROOM(0, 0, COL, LINENO-1, 0) ;
07300 END "TOLINE" ;
07400
07500 INTERNAL RECURSIVE PROCEDURE SKIPLINES(INTEGER HMLINES) ; IF ON THEN
07600 BEGIN "SKIPLINES"
07700 ASSUREAREA ;
07800 IF HMLINES > 0 THEN
07900 IF GROUPM=0 THEN FIND!ROOM(-HMLINES, 0, COL, LINE, 0)
08000 ELSE BEGIN "GROUP SKIP"
08100 INTEGER I ;
08200 FIND!ROOM(0, HMLINES, COL, LINE, 0) ;
08300 IF ¬GLINEM THEN GLINEM ← OLX + 1 ;
08400 FOR I ← 1 THRU HMLINES DO AA[COL, LINE+I] ←
08500 NEWBLANK(IF GLINEM=0 ∧ I=1 THEN ABV ELSE ABV!BLW) ;
08600 LINE ← LINE + HMLINES ;
08700 END "GROUP SKIP" ;
08800 END "SKIPLINES" ;
08900
00100 INTERNAL RECURSIVE PROCEDURE PLACELINE(INTEGER CHARS,POSN,XPOSN,FAKE,
00200 ABOVE,BELOW,LEADB,FIRSTLBL,JUSTIFY,MORECOMING) ;
00300 BEGIN "PLACELINE"
00400 INTEGER FOOTFLAG, NEEDS, TOPLINE, GR, ATOP, I, TOLBL, LBL, FOOTNUM, WASFRAME, WASCOL, WASOLX ;
00500 COMMENT FOOTFLAG CHANGES RKJ 10-10-73;
00600 STRING COWL, XREF, SOWL ;
00700 IF ¬DEBUG THEN XREF ← ALTMODE
00800 ELSE BEGIN
00900 XREF ← ERRLINE&"/"&SRCPAGE&"["&MACLINE&"]" ;
01000 FOR I ← 1 THRU MESGS DO XREF ← XREF & RUBOUT & MESSAGE[I] ;
01100 MESGS←0 ; XREF ← XREF & ALTMODE ;
01200 END ;
01300 IFC VERSION=SAILVER OR VERSION=PARCVER OR VERSION=ITSVER
01400 THENC IF XCRIBL THEN ABOVE←BELOW←0; comment scripts; ENDC
01500 COWL ← XREF & (SOWL←OWL[1 TO CHARS] & CRLF) ;
01600 ASSUREAREA ;
01700 IF COL > COLS THEN
01800 BEGIN "INFOOT" TES 12/6/73 SEPARATED CASES ;
01900 IF FOOTNUM ← FOOTTOP THEN
02000 BEGIN comment First Footnote belonging to a line ;
02100 GR ← GROUPM ; TES 1/15/74 ADDED 'OR GLINEM=0' BELOW: ;
02150 TES 8/22/74 PAL BELOW WAS COL! ;
02200 IF GROUPM=0 OR GLINEM=0 THEN GLINEM ← AA[PAL,PINE] ;
02300 GROUPM ← 1 ; FOOTTOP ← 0 ;
02400 END ;
02500 IF ATOP ← LINE=0 THEN ABOVE ← ABOVE + 1 + FOOTGAP ; comment assure room for FOOTSEP ;
02600 END "INFOOT" ;
02700 FOOTFLAG ← COL ≤ COLS AND FULSTR("SSTK[FOOTSTR(AREAIXM)]");
02800 IF FOOTFLAG THEN
02900 MORECOMING←MORECOMING+2; RKJ 11/20/73 ;
03000 WHILE ¬(TOPLINE ← FIND!ROOM(-LEADB,NEEDS←ABOVE+BELOW+1,COL,LINE,MORECOMING)) DO
03100 BEGIN ABOVE←(ABOVE-1)MAX 0; BELOW←(BELOW-1)MAX 0 END;
03200 IF XCRIBL AND (COL = 1 OR COL = COLS+1) THEN TES 11/19/73 COL 1 ONLY! ;
03300 BEGIN "KLUDGE"
03400 OVEREST←OVEREST+NEEDS*(STDCHARH-CHARH);
03500 IF ABS(OVEREST)>STDCHARH THEN
03600 BEGIN
03700 XGENLINES←XGENLINES+OVEREST DIV STDCHARH;
03800 OVEREST←OVEREST MOD STDCHARH;
03900 END;
04000 END "KLUDGE";
04100 WASOLX ← OLX - (LINE + 1 - TOPLINE) ;
04200 IF COL > COLS THEN
04300 BEGIN "BEGFOOT" TES 12/6/73 SEPARATED CASES ;
04400 IF FOOTNUM THEN COMMENT FIRST FOOTNOTE BELONGING TO A LINE ;
04500 BEGIN "FOOT1"
04600 GROUPM ← GR ; IF GROUPM=0 THEN GLINEM ← 0 ;
04700 END "FOOT1" ;
04800 IF ATOP THEN BEGIN ABOVE ← ABOVE - 1 - FOOTGAP ; TES 11/29/73 ;
04900 NEEDS ← NEEDS - 1 - FOOTGAP END ;
05000 IF LINE = 0 THEN
05100 BEGIN "SEP" TES 11/29/73 ADDED FOOTGAP AND ENOUGH ;
05200 FOR I ← 1 THRU FOOTGAP DO AA[COL,I] ←
05300 NEWBLANK(IF I=1 THEN ABV ELSE ABV!BLW) ;
05400 AA[COL, LINE←TOPLINE←1+FOOTGAP] ← OLX ← OLX + 1 ;
05500 IF XCRIBL THEN
05600 OWT(XREF&PICKFONT(FSFONT)&ENOUGH(FOOTSEP,COLWID(AREAIXM),FSFONT)&CRLF)
05700 ELSE
05800 OWT(XREF&FOOTSEP[1 TO COLWID(AREAIXM)]&CRLF) ;
05900 MOLES[OLX] ← IF FOOTGAP=0 THEN BLW ELSE ABV!BLW ;
06000 END "SEP" ;
06100 END "BEGFOOT" ;
06200 FOR I ← 1 THRU ABOVE DO AA[COL,LINE+I] ←
06300 NEWBLANK(IF GROUPM ∨ TOPLINE<LINE+I THEN ABV!BLW ELSE BLW) ;
06400 AA[COL, LINE+ABOVE+1] ← OLX ← OLX + 1 ;
06500 OWT(COWL) ;
06600 MOLES[OLX] ← (IF GROUPM ∨ TOPLINE<LINE+ABOVE+1 THEN ABV ELSE 0) LOR (IF GROUPM OR BELOW THEN BLW ELSE 0);
06700 IF XCRIBL THEN I←MAXIM*CHARW + FAKE - XPOSN ELSE I←MAXIM - (POSN-FAKE);
06800 IF JUSTIFY AND I > 0 THEN SHORT[OLX]←I ;
06900 IF FIRSTLBL≠-TWO(13) THEN
07000 BEGIN "PAGE LABELS"
07100 LBL ← PLBL ; TOLBL ← 0 ;
07200 WHILE LBL≠FIRSTLBL ∧ LBL≠-TWO(13) DO
07300 LBL ← IF (TOLBL←LBL)>0 THEN ITBL[TOLBL] ELSE NUMBER[-TOLBL] ;
07400 IF LBL=-TWO(13) THEN WARN("=","Page label not in Page Label L.L.!!!")
07500 ELSE IF TOLBL=0 THEN PLBL ← -TWO(13)
07600 ELSE IF TOLBL > 0 THEN ITBL[TOLBL] ← -TWO(13)
07700 ELSE NUMBER[-TOLBL] ← -TWO(13) ;
07800 BRKPLBL ← PLBL ;
07900 DPB(IF FIRSTLBL<0 THEN PUTI(1,FIRSTLBL) ELSE FIRSTLBL, LABELM(OLX)) ;
08000 END "PAGE LABELS" ;
08100 FOR I ← ABOVE+2 THRU NEEDS DO AA[COL,LINE+I] ← NEWBLANK(IF GROUPM ∨ I<NEEDS THEN ABV!BLW ELSE BLW) ;
08200 IF GROUPM∧¬GLINEM THEN
08300 DPB(0,ABOVEM("GLINEM←IF COL>COLS THEN TOPMOST(PAL,PINE) ELSE AA[COL,TOPLINE]")) ;
08400 TES 12/6/73 ADDED TOPMOST(PAL,PINE) ;
08500 LINE ← LINE + NEEDS ;
08600 IF FOOTFLAG THEN comment, Footnotes ;
08700 BEGIN "FOOTNOTES"
08800 WHILE (FOOTNUM←IF PINE=0 THEN 1 ELSE LDB(FOOTM("AA[PAL,PINE]")) + 1) = 31 DO
08900 BEGIN
09000 WARN("=",">30 lines in col. "&COL&" want footnotes.") ;
09100 FIND!ROOM(LINE, 1, COL+1, 0, 0) ;
09200 END ;
09300 IF FOOTNUM=32 THEN FOOTNUM ← 1 ; DPB(FOOTNUM, FOOTM(OLX)) ;
09400 SEND(IXFOOT, CRLF&TB&TB& "END ""!FOOTNOTES"";;") ;
09500 AA[COL,0] ← LHRH(COVERED, LINE) ; PINE ↔ LINE ; PAL ↔ COL ;
09600 WASCOL ← COL ; WASFRAME ← FRAMEIDA ; BEGINBLOCK(TRUE, 3, "!FOOTNOTES") ; BREAKM ← 0 ;
09700 FOOTTOP ← -1 ; WASOLX ← OLX ; RECEIVE(IXFOOT, NULL) ; PASS ; TOEND ; FOOTTOP ← 0 ;
09800 AA[COL,0] ← LHRH(COVERED, LINE) ;
09900 IF WASCOL ≠ COL ∨ WASFRAME ≠ FRAMEIDA THEN
10000 BEGIN FOOTNUM ← 31 ; IF WASFRAME=FRAMEIDA THEN DPB(31, FOOTM(WASOLX)) END ;
10100 DPB(FOOTNUM, FOOTM("AA[COL,LINE]")) ; PAL ↔ COL ; PINE ↔ LINE ;
10200 END "FOOTNOTES" ;
10300 END "PLACELINE" ;
00100 COMMENT I N I T I A L I Z A T I O N P R O C E D U R E S - - - - - - - - - - ;
00200
00300 INTERNAL SIMPLE PROCEDURE FAMILYHAS(INTEGER FAMNUM; STRING MEMBERS) ;
00400 BEGIN "FAMILYHAS"
00500 INTEGER SPECIE, CHAR ;
00600 SPECIE ← -1 ;
00700 WHILE FULSTR(MEMBERS) DO
00800 BEGIN
00900 DPB(FAMNUM, FAMILY("CHAR ← LOP(MEMBERS)")) ;
01000 DPB(SPECIE ← SPECIE+1, SPECIES(CHAR)) ;
01100 END ;
01200 END "FAMILYHAS" ;
01300
01400 EXTERNAL SIMPLE PROCEDURE MANUSCRIPT ;
00100 COMMENT I N I T I A L I Z E A N D G O ! ! ! ! ! ;
00200
00300 COMMENT Set up the XGP stuff ;
00400 CHARW ← 16 ; COMMENT fix later ;
00500 WCW ← WHATIS(CW) ; COMMENT original font ;
00600 THISFONT ← OLDFONT ← DEFAULTFONT ;
00700
00800 FSFONT ← DEFAULTFONT ; FOOTGAP ← 0 ; TES 11/29/73 ;
00900
01000 IFC TENEX THENC
01100 JOBNO ← CVS(GJINF(J, I, J)) ;
01200 CONDIR ← DIRST(I) ;
01300 ENDC TES 10/25/73 ;
01400
01500 DOPASS3←FALSE; RKJ: 1-4-74;
01504 ERRLF←FALSE; RKJ 6/25/74 ;
01552 DEBUGFLAG ← -1 ; TES 8/21/74 ;
01600
01700 ON ← TRUE ; comment only false if code is to be parsed but not executed ;
01800 WISTK←WHATIS(ISTK) ; WITBL←WHATIS(ITBL) ; WINEST←WHATIS(INEST) ;
01900 WSSTK←SWHATIS(SSTK) ; WSTBL←SWHATIS(STBL) ; WSNEST←SWHATIS(SNEST) ;
02000 WSYM←SWHATIS(SYM) ; WNUMBER←WHATIS(NUMBER) ; WOLDPAGE←WHATIS(OLDPAGE) ;
02100 WNEWPAGE←WHATIS(NEWPAGE) ; WTHISFRAME←WHATIS(THISFRAME);
02200 WMOLES←WHATIS(MOLES) ; WOWLS←WHATIS(OWLS) ; WNMOLES←WHATIS(NMOLES) ;
02300 WNOWLS←WHATIS(NOWLS) ; WTHISAREA←WHATIS(THISAREA) ; WWAITBOX←WHATIS(WAITBOX) ;
02400 WAVAILREC←WHATIS(AVAILREC) ; WAA←WHATIS(AA) ; WNAA←WHATIS(NAA) ;
02500 WSHORT←WHATIS(SHORT) ; WNSHORT←WHATIS(NSHORT) ;
02600 ITBLIDA ← RH("CREATE(0, ITSIZE)") ; ISTKIDA ← RH("CREATE(0, ISIZE)") ; INESTIDA ← RH("CREATE(0, SIZE)") ;
02700 STBLIDA ← RH("SCREATE(0, STSIZE)") ; SSTKIDA ← RH("SCREATE(0, SSIZE)") ; SNESTIDA ← RH("SCREATE(0, SIZE)") ;
02800 SYMIDA ← RH("SCREATE(-1, SYMNO)") ; NUMBIDA ← RH("CREATE(-1, SYMNO)") ;
02900 MAKEBE(ITBLIDA, ITBL) ; MAKEBE(ISTKIDA, ISTK) ; MAKEBE(INESTIDA, INEST) ;
03000 SMAKEBE(STBLIDA, STBL) ; SMAKEBE(SSTKIDA, SSTK) ; SMAKEBE(SNESTIDA, SNEST) ;
03100 SMAKEBE(SYMIDA, SYM) ; MAKEBE(NUMBIDA, NUMBER) ;
03200 SETSYM ; XSYMNO ← SYMNO ; comment Initialize the symbol table;
03300 LAST ← IHED ← SHED ← IHIGH ← SHIGH ← 0 ; comment Tops of Stacks;
03400 OLDPGIDA←NEWPGIDA←FRAMEIDA←MOLESIDA←SHORTIDA←OWLSIDA←AREAIDA←WBOXIDA←STATUS←AREAIXM←0 ;
03500 DEPTH ← GENSYM ← 0 ; OLX ← -1 ; OLMAX ← 5 ; LEADRESPS ← WAITRESP ← 0 ;
03600 FOR I ← 0 STEP 1 WHILE FULSTR(MANWD[I]) DO
03700 BIND(DECLARE(SYMNUM(MANWD[I]), MANTYPE), I) ; comment reserved words ;
03800 DEPTH ← 2 ; IXCOMMENT ← LDB(IXN("SYMNUM(""""COMMENT"""")")) ;
03900 SYMTEXT ← SYMNUM("TEXT") ; IXEND←LDB(IXN("SYMNUM(""""END"""")"));
04000 J ← 0 ;
04100
04200 PJ 5/27/74 ITS does not like <control-C>'s;
04300
04400 FOR S ← CR, ALTMODE&"{", RUBOUT, "α", 3, "#", "\", "∂", "←", "→", "∞",
04500 "↑", "↓", "]", "-", ".!?", SP, "_", "π", "∪", "∩", VT, "$", "%",
04600 "⊗", "[", "&" DO
04700 COMMENT 2D CHARS OF DIPHTHONGS COME NOT BEFORE [ IN LIST ↑ ;
04800 BEGIN J←J+1; WHILE FULSTR(S) DO DPB(J, SPCHAR("LOP(S)")) ; END ;
04900 AMSAND ← J ; LBRACK ← J-1 ; UNDERBAR ← 18 ; UARROW ← 12 ; DARROW ← 13 ;
05000 LCURLY ← 2 ; DOLLAR ← 23 ; XCMDCHR ← 25 ;
05100 FOR S ← SP, TB, FF, VT, CR, LF, 0 DO CHARTBL[S] ← CHARTBL[S] LOR TWO(6) ;
05200 CHARSP ← CR & ALTMODE & RUBOUT & "α"&3&"#\∂←→∞↑↓]-? _π∪∩" & VT & "$%⊗[&" ;
05300 FOR J ← 0 THRU 127 DO BEGIN DPB(MISCQ, FAMILY(J)) ; DPB(0, SPECIES(J)) END ;
05400 FAMILYHAS(LETTQ, "ABCDEFGHIJKLMNOPQRSTUVWXYZ!") ;
05500 FAMILYHAS(LETTQ, "abcdefghijklmnopqrstuvwxyz_") ;
05600 FAMILYHAS(DIGQ, "0123456789" ) ;
05700 FAMILYHAS(EMPTYQ, '0 & ALTMODE & RUBOUT) ;
05800 FAMILYHAS(TERQ, RCBRAK&";),]⊂" ) ;
05900 FAMILYHAS(QUOTEQ, """'" ) ;
06000 FAMILYHAS(DOLLARQ, "$" ) ;
06100 FAMILYHAS(BROKQ, "[" ) ;
06200 FAMILYHAS(MULQ, "*/%&" ) ;
06300 FAMILYHAS(ADDQ, "+-≡↑⊗" ) ;
06400 FAMILYHAS(RELQ, "<>=≤≥≠" ) ;
06500 FAMILYHAS(NOTQ, "¬" ) ;
06600 FAMILYHAS(ANDQ, "∧" ) ;
06700 FAMILYHAS(ORQ, "∨" ) ;
06800 FAMILYHAS(MISCQ, " :←(∞@|ε" ) ;
06900 FOR S ← "∧AND", "∨OR", "¬NOT", "/DIV", "≡EQV", "⊗XOR", "≡ABS", "⊗LENGTH", "≤LEQ", "≥GEQ", "≠NEQ" DO
07000 BIND(DECLARE(SYMNUM(S[2 TO ∞]), INTERNTYPE), S+200) ; ie, equate with special character ;
07100 J ← RUBOUT ;
07200 FOR S ← ODDQ&0&"EVEN", ODDQ&1&"ODD",
07300 BOUNDQ&0&"MAX", BOUNDQ&1&"MIN", MULQ&2&"MOD", ADDQ&5&"XLENGTH" DO
07400 BEGIN
07500 INTEGER TEMP ; COMMENT SAIL BUG -- THANKS RKJ ;
07600 BIND(DECLARE(SYMNUM(S[3 TO ∞]), INTERNTYPE), (J←J+1)+200) ;
07700 DPB(TEMP←S[1 FOR 1], FAMILY(J)) ;
07800 DPB(TEMP←S[2 FOR 1], SPECIES(J)) ;
07900 END ;
00100 UPCAS3←(UPCASE(0)) LOR '3000000 ; COMMENT POINT 7, CHARTBL(3), 6 ;
00200 UPCAS5←(UPCASE(0)) LOR '5000000 ; UPCAS6←(UPCASE(0)) LOR '6000000 ;
00300 FOR J ← 0 THRU 127 DO DPB(J, UPCASE(J)) ;
00400 FOR J ← "a" THRU "z" DO DPB(J-("a"-"A"), UPCASE(J)) ; DPB(J←"!", UPCASE("_")) ;
00500 J ← -1 ;
00600 FOR S ← "LINES", "COLUMNS", "!", "SPREAD", "FILLING", "!SKIP!", "!SKIPL!", "!SKIPR!",
00700 "NULL", "!INF", "FOOTSEP", "TRUE", "FALSE",
00800 "INDENT1", "INDENT2", "INDENT3", "LMARG", "RMARG",
00900 "CHAR", "CHARS", "LINE", "COLUMN", "TOPLINE", "XCRIBL", "CHARW",
01000 "XGENLINES", "UNDERLINE", "THISDEVICE", "THISFONT",
01100 "FOOTGAP", "FOOTSEPFONT", "TTY", "ODDLEFTBORDER", "EVENLEFTBORDER",
01150 "FULLFILE", "THISLINE", "MAXTEMPLATE", "ERRLF", "DEBUGFLAG","!XGPLFTMAR" DO
01300 BIND(DECLARE(SYMNUM(S), INTERNTYPE), J←J+1) ; comment Internal Variables;
01400 PLBL←BRKPLBL←-TWO(13); NOPGPH ← TRUE ;
01500 BIND(DECLARE(SYMNUM("FOOT"), PORTYPE), IXFOOT ← PUTI(4, -1)) ;
01550 MAXTEMPLATE ← 5000 ; TES 8/19/74 ;
01600 VUNDERLINE ← BAR ; TES 10/22/73 ;
01700 ASSIGN("!CONTENTSW", CONTENTS) ; comment make RPG-switch available to macros;
01800 ASSIGN("FILE", IFILENAME) ;
01900 ! ← NULL ; K ← CALL(0, "DATE") ;
02000 ASSIGN("MONTH", (STR1 ← MONTH[K DIV 31 MOD 12 + 1])[1 TO ∞-1]) ;
02100 ASSIGN("DAY", STR2 ← CVS(K MOD 31 + 1)) ;
02200 ASSIGN("YEAR", STR3 ← CVS(K DIV 31 DIV 12 + 1964)) ;
02300 ASSIGN("DATE", STR1 & STR2 & ", " & STR3 );
02400 K ← CALL(0,"TIMER")/3600 ; S ← CVS(K MOD 60) ; IF LENGTH(S)=1 THEN S ← "0"&S ;
02500 ASSIGN("TIME", CVS(K DIV 60) & ":" & S) ;
02600 SYMPAGE←SYMNUM("PAGE"); CREUNIT(0,1,18,1,0,"1",SYMPAGE); IXPAGE←LDB(IXN(SYMPAGE));
02700 PATPAGE←PATT!STRS(IXPAGE); PAGEVAL ← NULL ;
02800 INTERS ← PORTS ← THISPORT ← 0 ; PORTLL ← SEQPORT ← PUTI(4, -5) ; PORSEQ(SEQPORT) ← INTER ← -1 ;
02900 PORSTR(SEQPORT) ← PUTS(NULL) ; PUTS(NULL) ;
03000 INPUTCHAN ← -1 ; LIT!ENTITY ← LIT!TRAIL ← NULL ;
03100 INPUTSTR ← CRLF & "99999/99" & TB & TB & "<<)]"&RCBRAK&"⊃>>;END""PAST EOF"";END""PASSED EOF"";" ;
03200 TABSORT[1]←TWO(33); EXNEXTPAGE ← FALSE ; ENDCASE←STARTS←0 ; BLNMS←-1 ; AVAILREC[0] ← NULLAREAS ← 0 ;
03300 EMPTYTHIS ; EMPTYTHAT ;
03400 RESP!BODY ← DCLR!ID ← DCLR!LET ← FALSE ; OWLSEQ ← MESGS ← 0 ;
03500 THISFILE ← "(NO FILE)" ; MAINFILE ← INFILE ; COMMENT RESET IN SWICHF ;
03600 COMMAND!CHARACTER ← "." ;
03700 S ← TEXT!BRC ← CRLF & ALTMODE & RUBOUT & VT & " -.!?" ;
03800 WHILE FULSTR(S) DO DPB(LDB(SPCHAR("J ← LOP(S)")), SPCODE(J)) ;
03900 DEFN!BRC ← RCBRAK&"$)⊂⊃∃" & LF & LETTS ; LDEFN!BRC ← LENGTH(DEFN!BRC) ;
04000 SETBREAK(TO!VT!SKIP, VT, NULL, "IS") ;
04100 SETBREAK(TO!COMMA!RPAR, ",)" & LF, CR, "IR") ;
04200 COMMENT "|" IGNORED UNTIL 6 FEB 73;
04300 SETBREAK(TO!TERQ!CR, RCBRAK&";),]⊂"&CRLF, NULL, "IR") ;
04400 SETBREAK(TO!SEMI!SKIP, ";"&RCBRAK&""&LF, NULL, "IS") ;
04500 SETBREAK(NO!CHARS, NULL, NULL, "XRL") ;
04600 SETBREAK(ONE!CHAR, NULL, NULL, "XA") ;
04700 SETBREAK(TO!TB!FF!SKIP, TB&FF, LF, "IS") ;
04800 SETBREAK(TO!LF!TB!VT!SKIP, LF&TB&VT, FF, "ISL") ;
04900 SETBREAK(TO!VISIBLE, SP&CR, NULL, "XR") ;
05000 SETBREAK(ALPHA, LETTS&DIGS, NULL, "XR") ;
05100 SETBREAK(DIGITA, DIGS, NULL, "XR") ;
05200 SETBREAK(TO!QUOTE!APPD, """"&LF, NULL, "IA") ;
05300 SETBREAK(TO!NON!SP, SP, NULL, "XR") ;
05400 SETBREAK(TEXT!TBL, TEXT!BRC&SIG!BRC,NULL, "IS") ;
05500 SETBREAK(TO!VBAR!SKIP, "|"&LF, CR, "IS") ;
05600 SETBREAK(DEFN!TABLE, DEFN!BRC, NULL, "IS") ;
05700 SETBREAK(TO!CR!SKIP, CRLF, NULL, "IS") ;
05750 ODDLEFTBORDER ← ODDLEFTBORDERDEFAULT ; EVENLEFTBORDER ← EVENLEFTBORDERDEFAULT ; TES 8/21/74 ;
05800 SWICH(CRLF & "9999/98" & TB & TB & "CLOSE TEXT;AFTER TEXT⊂⊃;NEXT PAGE;END ""!MANUSCRIPT"" ", -1, 0) ;
05900 SWICHFILE(INFILE, INCHAN) ; comment main input file ;
06000 IFC VERSION = PARCVER THENC
06100 BEGIN TES 1/22/74 OPTIONAL MYPUB.DFS ON USER DIRECTORY ;
06200 INTEGER CHAN ; EOF ← 0 ; CHAN ← GETCHAN ;
06300 OPEN(CHAN, "DSK", 0, 2, 0, 150, BRC, EOF) ;
06400 LOOKUP(CHAN, "MYPUB"&DFSEXT, FLAG) ;
06500 IF FLAG THEN RELEASE(CHAN)
06600 ELSE SWICHFILE("MYPUB"&DFSEXT,CHAN) ;
06700 END ;
06800 ENDC TES 1/22/74 ;
06900 SWICH("BEGIN ""!MANUSCRIPT"" ", -1, 0) ;
07000 IFC VERSION=CMUVER THENC
07100 LIBPPN ← "[A700PU00]";
07200 SIMLOOK("!DEFONTA");
07300 READFONT(DEFAULTFONT,"NGR25.KST[A730KS00]",NULL);
07400 ENDC COMMENT RKJ 10-10-73;
07500 IFC VERSION=SAILVER THENC
07600 LIBPPN ← IF EQU(CVXSTR(CALL(0,"DSKPPN"))[4 TO 6], "TES") THEN NULL ELSE "[1,3]" ;
07700 ENDC;
07800 IFC VERSION=ITSVER THENC PJ 5/27/74;
07900 LIBPPN ← " COMMON;" ; PJ 5/28/74 THE SPACE IS SIGNIFICNAT ;
08000 ENDC
08100 IFC TENEX THENC LIBPPN ← IF EQU(CONDIR,"PUB") THEN "<PUB>" ELSE "<SUBSYS>" ; ENDC
08150 !ERRP! ← LOCATIONOFERROR ← LOCATION(ERROR) ; TES 8/20/74 INTERCEPT SAIL ERRORS ;
08162 COMMENT CIRCUMVENT SAIL BUG BY USING LOCATIONOFERROR ;
08200 PUBSTD ← TRUE ; COMMENT SUPPRESS PAGE NUMBER MONITORING ;
08300 IFC TENEX THENC
08400 SWICHF(LIBPPN & "PUBSTD"&DFSEXT) ;
08500 ELSEC
08600 SWICHF("PUBSTD"&DFSEXT&LIBPPN) ; comment standard modes and macros ;
08700 ENDC
08800 SPREADM ← PREFMODE ;
08900 PASS ; comment get scanner going ;
00100 MANUSCRIPT ; NB NB NB NB T H I S D O E S P A S S O N E ;
00200
00300 COMMENT Write out Labels for Pass Two ;
00400 L ← WRITEON(FALSE, IFC TENEX THENC IFILENAME&".LABELS" ELSEC "PULABL"&PUIEXT ENDC) ;
00500 OUT(L, CVSR(XSYMNO MAX IHIGH) ) ;
00600 FOR J ← 1 THRU XSYMNO DO
00700 IF (BYTEWD ← NUMBER[J]) ≠ 0 ∧ (K← LDB(SYMBOLWD(BYTEWD))) = 0 ∨ K='17777 THEN
00800 IF LDB(PLIGHTWD(BYTEWD)) = 2 THEN OUT(L, CVSR(0) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))]&ALTMODE )
00900 ELSE WARN("=","Undefined Label "&SYM[J]) ;
01000 FOR J ← 1 THRU IHIGH DO IF LH(BYTEWD ← ITBL[J]) = '400000 THEN
01100 OUT(L, CVSR(1) & CVSR(J) & STBL[LDB(IXWD(BYTEWD))] & ALTMODE) ;
01200 RELEASE(L) ;
01300
01400 COMMENT Finish Last Page File and write out OUTFILE and Intermediate Sequence File ;
01500 IF INTER ≥ 0 THEN BEGIN FOR DUMMY←1 THRU 5 DO WORDOUT(INTER,-20) ; RELEASE(INTER) ; RELEASE(SINTER) END ;
01600 IF GENREXT THEN OUTFILE ← OUTFILE &
01700 IFC VERSION=CMUVER THENC (IF XCRIBL THEN ".XGO" ELSE ".DOC") ENDC
01800 IFC VERSION=SAILVER THENC (IF XCRIBL THEN ".XGP" ELSE ".DOC") ENDC
01900 IFC VERSION=PARCVER THENC DOCEXT ENDC
02000 IFC VERSION=ITSVER THENC DOCEXT ENDC; PJ 5/27/74;
02100 L ← WRITEON(FALSE,IFC TENEX THENC IFILENAME&".FILES" ELSEC "PUPSEQ"&PUIEXT ENDC) ;
02200 OUT(L, TMPFILE&ALTMODE&OUTFILE&ALTMODE&CVSR(DEBUG)&CVSR("ABS(DEVICE)")&DELINT&ALTMODE) ;
02300 TES 1/7/74 ; IFC VERSION=PARCVER THENC IF XCRIBL THEN
02400 BEGIN
02500 CMDFILE ← NULL ;
02600 FOR J ← 1 THRU HIFONT DO CMDFILE ← CMDFILE &
02700 (IF NULSTR(FNTNAME[J]) THEN "F DEFONT" & CR
02800 ELSE "F " & FNTNAME[J] & CR) ;
02900 OUT(L,CMDFILE&ALTMODE)
03000 END
03100 ENDC;
03110 IFC VERSION = SAILVER THENC
03120 IF XCRIBL THEN
03130 OUT(L,CMDFILE&(IF SIMLOOK("!XGPCOMMANDS") THEN
03140 EVALV("!XGPCOMMANDS", SYMIX, SYMTYPE) ELSE NULL)
03150 & ALTMODE) ;
03160 ENDC
03162 IFC VERSION=ITSVER THENC PJ 8/24/74 ;
03164 IF XCRIBL THEN
03166 BEGIN "WRITECMD"
03168 STRING CMDLINE; INTEGER BRC;
03170 IF SIMLOOK("!XGPCOMMANDS") THEN
03172 BEGIN
03174 CMDLINE←EVALV("!XGPCOMMANDS",SYMIX,SYMTYPE);
03176 SETBREAK(LOCAL_TABLE,"↔",NULL,"IS");
03178 DO OUT(L,SCAN(CMDLINE,LOCAL_TABLE,BRC)&CRLF) UNTIL BRC ≠ "↔";
03180 SETBREAK(LOCAL_TABLE,NULL,NULL,"IS");
03182 END;
03184 OUT(L,CMDFILE&ALTMODE);
03186 END "WRITECMD";
03188 ENDC
03200 OUT(L, VUNDERLINE & ALTMODE) ; TES 10/22/73 ;
03400 OUT(L,CVSR(CHARW));
03500 OUT(L, (IF SIMLOOK("!XGPLFTMAR") THEN EVALV("!XGPLFTMAR",SYMIX,SYMTYPE) ELSE LFTMARDEFAULT)&ALTMODE);
03600 OUT(L, (IF SIMLOOK("!XGPINTRA") THEN EVALV("!XGPINTRA",SYMIX,SYMTYPE) ELSE INTRADEFAULT)&ALTMODE);
03700 OUT(L,CVSR(BASELINE));
03800 OUT(L,CVSR(DOPASS3)); RKJ: 1-4-74;
03900 OUT(L,LF);
04000 IFC TENEX THENC COMMENT PASS2 COMMUNICATION FILE ;
04100 J←OPENFILE(JOBNO&".PASS2","WT") ;
04200 OUT(J, IFILENAME & ALTMODE) ;
04300 RELEASE(J) ;
04400 ENDC
04500 J ← PORSEQ(PORTLL) ;
04600 IFC NOT TENEX THENC OPEN(K ← GETCHAN, "DSK", 0,1,0,20, BRC, EOF) ; ENDC
04700 WHILE J > 0 DO
04800 BEGIN
04900 M← PORSTR(J) ; TES 3/20/74 ;
05000 IF FULSTR("PORINT(M)") THEN OUT(L, PORINT(M) & ALTMODE) ;
05100 IF PORCH(J) = -5 ∨ PORSEQ(J) < 0 THEN WARN("=","INSERT PORTION not found") ;
05200 IF FULSTR("PORFIL(M)") THEN
05300 FOR N←0,1 DO IF N=0 ∨ PORCH(J)=-6 THEN
05400 BEGIN COMMENT DELETE GENERATED FILES ;
05500 IFC TENEX THENC
05600 K ← OPENFILE(IFILENAME&(CASE N OF (GENEXT,ALFEXT))&PORFIL(M)&";*", "RO*") ;
05700 DO DELF(K) UNTIL NOT INDEXFILE(K) ;
05800 ELSEC
05900 LOOKUP(K, PORFIL(M) & (CASE N OF(PUGEXT,PUZEXT)), DUMMY) ;
06000 RENAME(K, NULL, 0, DUMMY) ;
06100 ENDC
06200 END ;
06300 J ← PORSEQ(J) ;
06400 END ;
06500 RELEASE(L) ; RELEASE(K) ;
06600
07900 FOR J ← ITBLIDA, ISTKIDA, INESTIDA, NUMBIDA DO GOAWAY(J) ;
08000 FOR J ← STBLIDA, SSTKIDA, SNESTIDA, SYMIDA DO GOAWAY(-1 LSH 18 + J) ;
08100 FOR J ← 1 THRU 35 DO IF FONTFIL[J] ≠ 0 THEN GOAWAY(FONTFIL[J]) ;
08200
08300 MAKEBE(WCW,CW);
08400 MAKEBE(WISTK, ISTK) ; MAKEBE(WITBL, ITBL) ; MAKEBE(WINEST, INEST) ;
08500 SMAKEBE(WSSTK, SSTK) ; SMAKEBE(WSTBL, STBL) ; SMAKEBE(WSNEST, SNEST) ;
08600 SMAKEBE(WSYM, SYM) ; MAKEBE(WNUMBER, NUMBER) ; MAKEBE(WOLDPAGE, OLDPAGE) ;
08700 MAKEBE(WNEWPAGE, NEWPAGE) ; MAKEBE(WTHISFRAME,THISFRAME);
08800 MAKEBE(WMOLES, MOLES) ; MAKEBE(WOWLS, OWLS) ; MAKEBE(WNMOLES, NMOLES) ;
08900 MAKEBE(WSHORT, SHORT) ; MAKEBE(WNSHORT, NSHORT) ;
09000 MAKEBE(WNOWLS, NOWLS) ; MAKEBE(WTHISAREA, THISAREA) ; MAKEBE(WWAITBOX, WAITBOX) ;
09100 MAKEBE(WAVAILREC, AVAILREC) ; MAKEBE(WAA, AA) ; MAKEBE(WNAA, NAA) ;
09200
09300 END "VARIABLE BOUND ARRAY BLOCK" ;
09400
09500 IFC TENEX THENC TES 10/25/73 ;
09600 BEGIN "PASS 2"
09700 RUNPRG(IF EQU(CONDIR,"PUB") THEN "<PUB>PUB2.SAV" ELSE "<SUBSYS>PUB2.SAV", 1,0) ;
09800 END "PASS 2"
09900 ELSEC
10000 IFC VERSION=CMUVER THENC
10100 BEGIN "PASS 2"
10200 INTEGER ARRAY PASSTWO[0:4];
10250 STRING S;
10300 PASSTWO[0] ← CVSIX(LIBDEV);
10400 S←CVXSTR(CALL('777777000003,"GETTAB"))&"2";
10410 SETBREAK(1,NULL," ","IS");
10420 PASSTWO[1] ← CVFIL(SCAN(S,1,DUMMY) &
10430 LIBPPN,PASSTWO[2],PASSTWO[4]);
10500 PASSTWO[3] ← 0;
10600 START!CODE
10700 MOVE 1,PASSTWO;
10800 HRLI 1,1;
10900 CALLI 1,'35;
11000 JRST 4,0;
11100 END;
11200 END "PASS 2"
11300 ELSEC
11400 IFC VERSION=SAILVER OR VERSION=ITSVER THENC
11500 BEGIN "PASS 2"
11600 IFC VERSION=SAILVER
11700 THENC DEFINE PUB2!DMP="""PUB2.DMP""";
11800 ELSEC DEFINE PUB2!DMP="""TS PUB2"""; ENDC PJ 5/27/74 ;
11900 INTEGER SIMPLE PROCEDURE CORELOC(INTEGER ARRAY A) ; START!CODE MOVE 1,A ; END ;
12000
12100 INTEGER ARRAY PASSTWO[0:4] ;
12200 EXTERNAL SIMPLE PROCEDURE K!OUT ; K!OUT ; COMMENT * * * * * * * * * * * ;
12300 PASSTWO[0] ← CVSIX("DSK") ; PASSTWO[1] ← CVFIL(PUB2!DMP&LIBPPN, PASSTWO[2], PASSTWO[4]) ;
12400 PASSTWO[3] ← 1 ; COMMENT Do an RPGSTART so DEVICE will be taken from PUI file ;
12500 CALL(CORELOC(PASSTWO), "SWAP") ;
12600 END "PASS 2"
12700 ELSEC
12800 IFC VERSION=PARCVER THENC
12900 BEGIN "PASS 2" RKJ NON-TENEX SAIL ;
13000 INTEGER FH;
13100 DEFINE JSYS="'104000000000",
13200 RESET="JSYS '147", GTJFN="JSYS '20",
13300 CFORK="JSYS '152", WFORK="JSYS '163",
13400 HALTF="JSYS '170", GET="JSYS '200",
13500 SFRKV="JSYS '201";
13600 S←"<SUBSYS>PUB2.SAV "; TES 10/25/73 ;
13700 START!CODE
13800 RESET;
13900 MOVSI 1,'200000;
14000 CFORK; HALTF;
14100 MOVEM 1,FH;
14200 MOVSI 1,'100001;
14300 MOVE 2,S;
14400 GTJFN; HALTF;
14500 HRL 1,FH;
14600 GET;
14700 MOVE 1,FH;
14800 MOVEI 2,2;
14900 SFRKV;
15000 MOVE 1,FH;
15100 WFORK;
15200 RESET;
15300 HALTF;
15400 END;
15500 END "PASS 2";
15600 ENDC ENDC ENDC ENDC
15700
15800 END "PUB"